├── sandbox ├── perl.supp ├── Eye.readme ├── Eye.jpg ├── leaktest ├── dick.pl ├── subwidget.pl ├── testclock.pl ├── genMETA.pl └── genMETA.pm ├── t ├── eye.png ├── eye2.png ├── 00_pod.t ├── 01_pod.t ├── 20_resize.t ├── 40_backdrop.t ├── 50_infotext.t ├── 30_dual.t └── 10_base.t ├── examples ├── world.pl ├── simple.pl ├── 24hour.pl ├── countdown.pl ├── station.pl ├── random.pl └── cdclock.pl ├── .gitignore ├── .whitesource ├── xt ├── 10_perm.t ├── 50_manifest.t ├── 02_pod.t └── 00_perlversion.t ├── MANIFEST.SKIP ├── .releaserc ├── MANIFEST ├── .aspell.local.pws ├── cpanfile ├── .travis.yml ├── CONTRIBUTING.md ├── README ├── Makefile.PL ├── ChangeLog ├── doc ├── Clock.md ├── Clock.man ├── Clock.html └── Clock.3 └── Clock.pm /sandbox/perl.supp: -------------------------------------------------------------------------------- 1 | /pro/3gl/CPAN/perl/t/perl.supp -------------------------------------------------------------------------------- /t/eye.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tux/Tk-Clock/master/t/eye.png -------------------------------------------------------------------------------- /sandbox/Eye.readme: -------------------------------------------------------------------------------- 1 | convert -crop 242x269+226+101 Eye.jpg ../t/eye.png 2 | -------------------------------------------------------------------------------- /t/eye2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tux/Tk-Clock/master/t/eye2.png -------------------------------------------------------------------------------- /sandbox/Eye.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tux/Tk-Clock/master/sandbox/Eye.jpg -------------------------------------------------------------------------------- /examples/world.pl: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tux/Tk-Clock/master/examples/world.pl -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | blib 2 | cover_db 3 | Makefile 4 | META.json 5 | META.yml 6 | MYMETA.json 7 | MYMETA.yml 8 | pm_to_blib 9 | Tk 10 | *.tar.gz 11 | *.tgz 12 | *.old 13 | *.tmp 14 | -------------------------------------------------------------------------------- /.whitesource: -------------------------------------------------------------------------------- 1 | { 2 | "generalSettings": { 3 | "shouldScanRepo": true 4 | }, 5 | "checkRunSettings": { 6 | "vulnerableCheckRunConclusionLevel": "failure" 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /t/00_pod.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use Test::More; 4 | 5 | eval "use Test::Pod 1.00"; 6 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; 7 | all_pod_files_ok (); 8 | -------------------------------------------------------------------------------- /xt/10_perm.t: -------------------------------------------------------------------------------- 1 | use Test::PAUSE::Permissions; 2 | 3 | BEGIN { $ENV{RELEASE_TESTING} = 1; } 4 | 5 | my $usr = lc getpwuid ($<) || "joe"; 6 | plan skip_all => "You are not me" unless $usr =~ m/^(?:merijn|tux)$/; 7 | 8 | all_permissions_ok ("HMBRAND"); 9 | -------------------------------------------------------------------------------- /xt/50_manifest.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | eval "use Test::DistManifest"; 8 | plan skip_all => "Test::DistManifest required for testing MANIFEST" if $@; 9 | manifest_ok (); 10 | done_testing; 11 | -------------------------------------------------------------------------------- /sandbox/leaktest: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PERL=$1 4 | HRNS=$2 5 | shift ; shift 6 | 7 | export PERL_DL_NONLAZY=1 8 | export PERL_DESTRUCT_LEVEL=2 9 | 10 | for t in $@ ; do 11 | echo $PERL $t 12 | $PERL -MExtUtils::Command::MM -e "$HRNS" -MTest::Valgrind $t 13 | done 14 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | \.git 2 | \.travis.yml 3 | \.whitesource 4 | blib/ 5 | cover_db/ 6 | Makefile$ 7 | MANIFEST.SKIP 8 | MYMETA.json 9 | MYMETA.yml 10 | pm_to_blib 11 | Tk$ 12 | sandbox/ 13 | xt/ 14 | ^doc/ 15 | \.releaserc 16 | \.aspell.local.pws 17 | \.tar\.gz$ 18 | \.tgz$ 19 | \.tbz$ 20 | \.tmp$ 21 | -------------------------------------------------------------------------------- /t/01_pod.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use Test::More; 4 | 5 | eval "use Test::Pod::Coverage tests => 1"; 6 | plan skip_all => "Test::Pod::Covarage required for testing POD Coverage" if $@; 7 | pod_coverage_ok ("Tk::Clock", 8 | { also_private => [ qr{^ Populate $}x ], }, 9 | "Tk::Clock is covered"); 10 | -------------------------------------------------------------------------------- /examples/simple.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | # A default clock the starts at 1.5 time original size and is scalable 4 | use Tk; 5 | use Tk::Clock; 6 | 7 | my $m = MainWindow->new; 8 | my $c = $m->Clock->pack (-expand => 1, -fill => "both"); 9 | $c->config (anaScale => 150)->config (anaScale => 0); 10 | 11 | MainLoop; 12 | -------------------------------------------------------------------------------- /xt/02_pod.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use Test::More; 4 | 5 | eval "use Test::Pod::Links"; 6 | plan skip_all => "Test::Pod::Links required for testing POD Links" if $@; 7 | eval { 8 | no warnings "redefine"; 9 | no warnings "once"; 10 | *Test::XTFiles::all_files = sub { sort glob "*.pm"; }; 11 | }; 12 | Test::Pod::Links->new->all_pod_files_ok; 13 | -------------------------------------------------------------------------------- /examples/24hour.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | # A weird clock where the hour hand uses a 24-hour scale 4 | use Tk; 5 | use Tk::Clock; 6 | 7 | my $m = MainWindow->new; 8 | my $c = $m->Clock->pack (-expand => 1, -fill => "both"); 9 | $c->config ( 10 | anaScale => 250, 11 | ana24hour => 1, 12 | tickFreq => 2.5, 13 | )->config (anaScale => 0); 14 | 15 | MainLoop; 16 | -------------------------------------------------------------------------------- /.releaserc: -------------------------------------------------------------------------------- 1 | cpan_user HMBRAND 2 | automated_testing 1 3 | skip_kwalitee 1 4 | skip_manifest 1 5 | skip_prereqs 1 6 | skip_changes 1 7 | skip_dist 1 8 | ignore_untracked 1 9 | allow_glob_in_perls 1 10 | perls /pro/bin/perl\ 11 | :/pro/bin/perl5.8.8\ 12 | :/pro/bin/perl5.[1234][02468].*\ 13 | :/pro/bin/perl5.41.*\ 14 | :/pro/bin/tperl5.8.8\ 15 | :/pro/bin/tperl5.[1234][02468].*\ 16 | :/pro/bin/tperl5.41.*\ 17 | :/usr/bin/perl 18 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | ChangeLog 2 | MANIFEST 3 | Makefile.PL 4 | README 5 | CONTRIBUTING.md 6 | cpanfile 7 | Clock.pm 8 | examples/24hour.pl 9 | examples/cdclock.pl 10 | examples/countdown.pl 11 | examples/random.pl 12 | examples/simple.pl 13 | examples/station.pl 14 | examples/world.pl 15 | t/00_pod.t 16 | t/01_pod.t 17 | t/10_base.t 18 | t/20_resize.t 19 | t/30_dual.t 20 | t/40_backdrop.t 21 | t/50_infotext.t 22 | t/eye.png 23 | t/eye2.png 24 | -------------------------------------------------------------------------------- /examples/countdown.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use Tk; 4 | use Tk::Clock; 5 | 6 | my $m = MainWindow->new; 7 | my $c = $m->Clock (-background => "Black")->pack (-expand => 1, -fill => "both"); 8 | $c->config ( 9 | useDigital => 0, 10 | useAnalog => 1, 11 | handColor => "White", 12 | secsColor => "Red", 13 | tickColor => "White", 14 | tickFreq => 1, 15 | tickDiff => 1, 16 | handCenter => 1, 17 | countDown => time, 18 | anaScale => 500, 19 | ); 20 | $c->config (anaScale => 0); # Allow resize 21 | 22 | MainLoop; 23 | -------------------------------------------------------------------------------- /xt/00_perlversion.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | eval "use Test::More 0.93"; 7 | if ($@ || $] < 5.010) { 8 | print "1..0 # perl-5.10.0 + Test::More 0.93 required for version checks\n"; 9 | exit 0; 10 | } 11 | eval "use Test::MinimumVersion"; 12 | if ($@) { 13 | print "1..0 # Test::MinimumVersion required for compatability tests\n"; 14 | exit 0; 15 | } 16 | 17 | all_minimum_version_ok ("5.006", { paths => [ sort 18 | glob ("t/*.t"), glob ("xt/*"), glob ("*.pm"), glob ("*.PL"), 19 | ]}); 20 | 21 | done_testing (); 22 | -------------------------------------------------------------------------------- /sandbox/dick.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use Tk; 4 | use Tk::Clock; 5 | 6 | my $m = MainWindow->new (); 7 | 8 | #$m->overrideredirect (1); #no xterm decorations 9 | my $c = $m->Clock (-background => "Black"); 10 | $c->config ( 11 | useAnalog => 0, 12 | useDigital => 1, 13 | digiAlign => "center", 14 | timeColor => "lightBlue", 15 | timeFormat => "h:MM:SS A", 16 | dateColor => "lightBlue", 17 | dateFormat => "dd-mm-yyyy", 18 | dateFont => "fixed 18", 19 | timeFont => "fixed 24", 20 | localOffset => $ARGV[0]||0, 21 | ); 22 | $c->pack; 23 | 24 | MainLoop; 25 | -------------------------------------------------------------------------------- /.aspell.local.pws: -------------------------------------------------------------------------------- 1 | personal_ws-1.1 en 45 2 | Achim 3 | anaScale 4 | API 5 | autoScale 6 | backDrop 7 | Bohnet 8 | countDown 9 | CPAN 10 | dateColor 11 | dateFont 12 | dateFormat 13 | digiAlign 14 | handCenter 15 | handColor 16 | infoColor 17 | infoFont 18 | infoFormat 19 | Ing 20 | localOffset 21 | multi 22 | OO 23 | perlTk 24 | resize 25 | secsColor 26 | Srinivasan 27 | Sriram 28 | Subwidgets 29 | textColor 30 | textFont 31 | textFormat 32 | tickColor 33 | tickDiff 34 | tickFreq 35 | timeColor 36 | timeFont 37 | timeFormat 38 | timerValue 39 | Tk 40 | useAnalog 41 | useDigital 42 | useInfo 43 | useLocale 44 | useSecHand 45 | useText 46 | yy 47 | -------------------------------------------------------------------------------- /sandbox/subwidget.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use 5.018003; 4 | use warnings; 5 | 6 | use Tk; 7 | use Tk::Clock; 8 | 9 | my $fg0 = "Black"; 10 | 11 | my $mw = MainWindow->new; 12 | my $clock = $mw->Clock (-borderwidth => 1)->pack; 13 | $clock->config ( 14 | useDigital => 1, 15 | useAnalog => 0, 16 | useSecHand => 0, 17 | digiAlign => "right", 18 | dateColor => $fg0, 19 | timeColor => $fg0, 20 | dateFont => "{DejaVu Sans Mono} 15", 21 | timeFont => "{DejaVu Sans Mono} 8", 22 | dateFormat => "d.m.yyyy", 23 | autoScale => 1, 24 | ); 25 | 26 | use Data::Peek; 27 | $mw->after ( 5, sub { $clock->itemconfigure ("date", -fill => "Red") }); 28 | 29 | MainLoop; 30 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires "Carp"; 2 | requires "Encode"; 3 | requires "POSIX"; 4 | requires "Tk" => "402.000"; 5 | requires "Tk::Canvas"; 6 | requires "Tk::Derived"; 7 | requires "Tk::Widget"; 8 | 9 | recommends "Encode" => "3.21"; 10 | recommends "Tk" => "804.036"; 11 | 12 | on "configure" => sub { 13 | requires "ExtUtils::MakeMaker"; 14 | 15 | recommends "ExtUtils::MakeMaker" => "7.22"; 16 | 17 | suggests "ExtUtils::MakeMaker" => "7.70"; 18 | }; 19 | 20 | on "test" => sub { 21 | requires "Test::More" => "0.90"; 22 | requires "Test::NoWarnings"; 23 | 24 | recommends "Test::More" => "1.302207"; 25 | }; 26 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | os: 3 | - linux 4 | dist: trusty 5 | perl: 6 | - "5.30" 7 | - "5.28" 8 | - "5.26" 9 | - "5.26-shrplib" 10 | - "5.24" 11 | - "5.22" 12 | - "5.20" 13 | - "5.18" 14 | - "5.16" 15 | - "5.14" 16 | - "5.12" 17 | - "5.10" 18 | - "5.8" 19 | env: 20 | global: 21 | - AUTOMATED_TESTING=1 22 | - TK_TEST_LENGTH=120 23 | before_install: 24 | - sudo apt-get update -qq 25 | - sudo apt-get install -qq xvfb 26 | - Xvfb :123 & 27 | - export DISPLAY=:123 28 | - (sleep 10; twm) & 29 | before_install: 30 | - brew install cpanm || true 31 | install: 32 | - cpanm --quiet --installdeps --notest . || true 33 | notifications: 34 | irc: 35 | channels: 36 | - "irc.perl.org#csv" 37 | on_success: always 38 | on_failure: always 39 | -------------------------------------------------------------------------------- /examples/station.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use Tk; 4 | use Tk::Clock; 5 | 6 | my @bw = qw( Black White ); 7 | 8 | use Getopt::Long qw(:config bundling nopermute); 9 | GetOptions ( 10 | "r|rev|wb|white-on-black" => sub { @bw = reverse @bw }, 11 | ) or die "usage: station.pl [--white-on-black]\n"; 12 | 13 | my $m = MainWindow->new; 14 | 15 | $m->configure ( 16 | -foreground => $bw[0], 17 | -background => $bw[1], 18 | ); 19 | 20 | my $c = $m->Clock ( 21 | -background => $bw[1], 22 | -relief => "flat", 23 | )->pack ( 24 | -anchor => "c", 25 | -expand => 1, 26 | -fill => "both", 27 | -padx => "10", 28 | -pady => "10", 29 | ); 30 | $c->config ( 31 | useDigital => 0, 32 | useAnalog => 1, 33 | secsColor => "Red", 34 | handColor => $bw[0], 35 | tickColor => $bw[0], 36 | tickFreq => 1, 37 | tickDiff => 1, 38 | handCenter => 1, 39 | anaScale => 500, 40 | autoScale => 1, 41 | ); 42 | 43 | MainLoop; 44 | -------------------------------------------------------------------------------- /examples/random.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use Tk; 4 | use Tk::Clock; 5 | 6 | my @bw = qw( Black White ); 7 | 8 | use Getopt::Long qw(:config bundling nopermute); 9 | GetOptions ( 10 | "r|rev|wb|white-on-black" => sub { @bw = reverse @bw }, 11 | ) or die "usage: station.pl [--white-on-black]\n"; 12 | 13 | my $m = MainWindow->new; 14 | 15 | $m->configure ( 16 | -foreground => $bw[0], 17 | -background => $bw[1], 18 | ); 19 | 20 | my $c = $m->Clock ( 21 | -background => $bw[1], 22 | -relief => "flat", 23 | )->pack ( 24 | -anchor => "c", 25 | -expand => 1, 26 | -fill => "both", 27 | -padx => "10", 28 | -pady => "10", 29 | ); 30 | $c->config ( 31 | useDigital => 0, 32 | useAnalog => 1, 33 | secsColor => "Red", 34 | handColor => $bw[0], 35 | tickColor => $bw[0], 36 | tickFreq => 1, 37 | tickDiff => 1, 38 | handCenter => 1, 39 | anaScale => 500, 40 | autoScale => 1, 41 | ); 42 | 43 | srand (time); 44 | $m->repeat (2500, sub { $c->config (localOffset => int rand 86400); }); 45 | 46 | MainLoop; 47 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # General 2 | 3 | I am always open to improvements and suggestions. 4 | Use [issues](https://github.com/Tux/Tk-Clock/issues) 5 | 6 | # Style 7 | 8 | I will never accept pull request that do not strictly conform to my 9 | style, however you might hate it. You can read the reasoning behind 10 | my [preferences](http://tux.nl/style.html). 11 | 12 | I really do not care about mixed spaces and tabs in (leading) whitespace 13 | 14 | Perl::Tidy will help getting the code in shape, but as all software, it 15 | is not perfect. You can find my preferences for these in 16 | [.perltidy](https://github.com/Tux/Release-Checklist/blob/master/.perltidyrc) and 17 | [.perlcritic](https://github.com/Tux/Release-Checklist/blob/master/.perlcriticrc). 18 | 19 | # Mail 20 | 21 | Please, please, please, do *NOT* use HTML mail. 22 | [Plain text](https://useplaintext.email) 23 | [without](http://www.goldmark.org/jeff/stupid-disclaimers/) 24 | [disclaimers](https://www.economist.com/business/2011/04/07/spare-us-the-e-mail-yada-yada) 25 | will do fine! 26 | 27 | # Requirements 28 | 29 | The minimum version required to use this module is stated in 30 | [Makefile.PL](./Makefile.PL) 31 | -------------------------------------------------------------------------------- /t/20_resize.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | require Test::NoWarnings; 8 | 9 | BEGIN { 10 | use_ok ("Tk"); 11 | use_ok ("Tk::Clock"); 12 | } 13 | 14 | my ($delay, $m, $c) = ($ENV{TK_TEST_LENGTH} || 5000) * 2; 15 | unless ($m = eval { MainWindow->new (-title => "clock") }) { 16 | diag ("No valid Tk environment"); 17 | done_testing; 18 | exit 0; 19 | } 20 | 21 | ok ($c = $m->Clock (-background => "Black"), "Clock Widget"); 22 | like ($c->config ( 23 | tickColor => "Orange", 24 | handColor => "Red", 25 | secsColor => "Green", 26 | timeColor => "lightBlue", 27 | dateColor => "Gold", 28 | timeFont => "-misc-fixed-medium-r-normal--13-*-75-75-c-*-iso8859-1", 29 | autoScale => 1, 30 | ), qr(^Tk::Clock=HASH), "config"); 31 | ok ($c->pack (-expand => 1, -fill => "both"), "pack"); 32 | 33 | print "# Feel free to resize the clock now with your mouse!\n"; 34 | 35 | $c->after ($delay, sub { 36 | $c->destroy; 37 | ok (!Exists ($c), "Destroy Clock"); 38 | $m->destroy; 39 | ok (!Exists ($m), "Destroy Main"); 40 | 41 | Test::NoWarnings::had_no_warnings (); 42 | done_testing; 43 | }); 44 | 45 | MainLoop; 46 | -------------------------------------------------------------------------------- /sandbox/testclock.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use Tk; 4 | use Tk::Clock; 5 | 6 | my @bw = qw( White Black ); 7 | 8 | my $m = MainWindow->new; 9 | 10 | $m->configure ( 11 | -foreground => $bw[0], 12 | -background => $bw[1], 13 | ); 14 | 15 | my $locale = $^O eq "MSWin32" ? "Hungarian_Hungary" : @ARGV ? "hu_HU" : "hu_HU.utf8"; 16 | my $c = $m->Clock ( 17 | -background => $bw[1], 18 | -relief => "flat", 19 | )->pack ( 20 | -anchor => "c", 21 | -expand => 1, 22 | -fill => "both", 23 | -padx => "10", 24 | -pady => "10", 25 | ); 26 | $c->config ( 27 | useDigital => 1, 28 | useAnalog => 1, 29 | useSecHand => 0, 30 | handColor => $bw[0], 31 | tickColor => $bw[0], 32 | tickFreq => 1, 33 | tickDiff => 1, 34 | handCenter => 1, 35 | anaScale => 500, 36 | autoScale => 1, 37 | useInfo => 1, 38 | infoColor => "Yellow", 39 | timeColor => "Yellow", 40 | dateColor => "Yellow", 41 | infoFormat => "mmmm", 42 | handColor => "Gray60", 43 | timeZone => "Europe/Budapest", 44 | useLocale => $locale, 45 | timeFont => "{DejaVu Sans Mono} 10", 46 | timeFormat => "", #"Hungary/Budapest", 47 | localOffset => -2 * 86400, 48 | infoFont => "{DejaVu Sans Mono} 18", 49 | dateFont => "{DejaVu Sans Mono} 18", 50 | dateFormat => "ddd dddd", 51 | ); 52 | 53 | MainLoop; 54 | -------------------------------------------------------------------------------- /t/40_backdrop.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | require Test::NoWarnings; 8 | 9 | BEGIN { 10 | use_ok ("Tk"); 11 | use_ok ("Tk::Photo"); 12 | use_ok ("Tk::Clock"); 13 | } 14 | 15 | eval { require Tk::PNG; }; 16 | unless ($Tk::PNG::VERSION) { 17 | diag "SKIP: cannot load Tk::PNG"; 18 | done_testing; 19 | exit 0; 20 | } 21 | 22 | my ($delay, $m) = $ENV{TK_TEST_LENGTH} || 5000; 23 | unless ($m = eval { MainWindow->new (-title => "clock") }) { 24 | diag ("No valid Tk environment"); 25 | done_testing; 26 | exit 0; 27 | } 28 | 29 | ok (my $c = $m->Clock (-relief => "flat"), "base clock"); 30 | ok (my $p1 = $m->Photo (-file => "t/eye.png"), "Photo 1"); 31 | ok (my $p2 = $m->Photo (-file => "t/eye2.png"), "Photo 2"); 32 | ok ($c->config ( 33 | backDrop => $p1, 34 | timeFont => "{Liberation Mono} 11", 35 | dateFont => "{Liberation Mono} 11", 36 | timeFormat => " ", 37 | dateFormat => "ddd, dd mmm yyyy", 38 | dateColor => "Navy", 39 | handColor => "#ffe0e0", 40 | useSecHand => 0, 41 | tickColor => "Blue", 42 | tickDiff => 1, 43 | handCenter => 1, 44 | anaScale => 330, 45 | ), "config ()"); 46 | ok ($c->pack, "pack"); 47 | 48 | $c->after ( $delay, sub { $c->config (backDrop => $p2) }); 49 | 50 | $c->after (2 * $delay, sub { $_->destroy for $c, $m; 51 | Test::NoWarnings::had_no_warnings (); 52 | done_testing; 53 | }); 54 | 55 | MainLoop; 56 | -------------------------------------------------------------------------------- /t/50_infotext.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | require Test::NoWarnings; 8 | 9 | BEGIN { 10 | use_ok ("Tk"); 11 | use_ok ("Tk::Clock"); 12 | } 13 | 14 | my ($delay, $m) = $ENV{TK_TEST_LENGTH} || 1000; 15 | unless ($m = eval { MainWindow->new (-title => "clock") }) { 16 | diag ("No valid Tk environment"); 17 | done_testing; 18 | exit 0; 19 | } 20 | 21 | ok (my $c = $m->Clock (-relief => "flat"), "base clock"); 22 | ok ($c->config ( 23 | useAnalog => 1, 24 | useDigital => 1, 25 | dateFont => "{DejaVu Sans Mono} 11", 26 | timeFont => "{DejaVu Sans Mono} 11", 27 | infoFont => "{DejaVu Sans Mono} 11", 28 | textFont => "{DejaVu Sans Mono} 11", 29 | dateColor => "Blue", 30 | timeColor => "Red", 31 | infoColor => "Green", 32 | textColor => "Orange", 33 | handColor => "#ffe0e0", 34 | useSecHand => 0, 35 | tickColor => "Blue", 36 | tickDiff => 1, 37 | handCenter => 1, 38 | anaScale => 330, 39 | ), "base config ()"); 40 | $c->pack (-expand => 1, -expand => "both"); 41 | 42 | sub text { int rand 9000 }; 43 | 44 | my $ix = 15; 45 | sub next_ix { 46 | my $use_dt = $ix & 010; 47 | my $use_tm = $ix & 004; 48 | my $use_if = $ix & 002; 49 | my $use_tx = $ix & 001; 50 | 51 | ok ($c->config ( 52 | useInfo => $use_if, 53 | useText => $use_tx, 54 | dateFormat => $use_dt ? "yyyy-mm-dd" : " ", 55 | timeFormat => $use_tm ? "HH:MM:SS" : " ", 56 | infoFormat => $use_if ? "Info" : " ", 57 | textFormat => $use_tx ? \&text : " ", 58 | ), "config ($ix, $use_dt, $use_tm, $use_if, $use_tx)"); 59 | $c->update; 60 | if ($ix--) { 61 | $c->after ($delay, \&next_ix); 62 | } 63 | else { 64 | $c->packForget; 65 | $c->destroy; 66 | Test::NoWarnings::had_no_warnings (); 67 | done_testing; 68 | exit 0; 69 | } 70 | } # next_ix 71 | 72 | $c->after ($delay, \&next_ix); 73 | 74 | MainLoop; 75 | -------------------------------------------------------------------------------- /sandbox/genMETA.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Getopt::Long qw(:config bundling nopermute); 7 | my $check = 0; 8 | my $opt_v = 0; 9 | GetOptions ( 10 | "c|check" => \$check, 11 | "v|verbose:1" => \$opt_v, 12 | ) or die "usage: $0 [--check]\n"; 13 | 14 | use lib "sandbox"; 15 | use genMETA; 16 | my $meta = genMETA->new ( 17 | from => "Clock.pm", 18 | verbose => $opt_v, 19 | ); 20 | 21 | $meta->from_data (); 22 | $meta->gen_cpanfile (); 23 | 24 | if ($check) { 25 | $meta->check_encoding (); 26 | $meta->check_required (); 27 | $meta->check_minimum ([ "examples" ]); 28 | $meta->done_testing (); 29 | } 30 | elsif ($opt_v) { 31 | $meta->print_yaml (); 32 | } 33 | else { 34 | $meta->fix_meta (); 35 | } 36 | 37 | __END__ 38 | --- #YAML:1.0 39 | name: Tk-Clock 40 | version: VERSION 41 | abstract: Clock widget with analog and digital display 42 | license: perl 43 | author: 44 | - H.Merijn Brand 45 | generated_by: Author 46 | distribution_type: module 47 | provides: 48 | Tk::Clock: 49 | file: Clock.pm 50 | version: VERSION 51 | requires: 52 | perl: 5.006 53 | Carp: 0 54 | Tk: 402.000 55 | Tk::Widget: 0 56 | Tk::Derived: 0 57 | Tk::Canvas: 0 58 | Encode: 0 59 | POSIX: 0 60 | recommends: 61 | Tk: 804.036 62 | Encode: 3.21 63 | configure_requires: 64 | ExtUtils::MakeMaker: 0 65 | configure_recommends: 66 | ExtUtils::MakeMaker: 7.22 67 | configure_suggests: 68 | ExtUtils::MakeMaker: 7.70 69 | test_requires: 70 | Test::More: 0.90 71 | Test::NoWarnings: 0 72 | test_recommends: 73 | Test::More: 1.302207 74 | resources: 75 | license: http://dev.perl.org/licenses/ 76 | repository: https://github.com/Tux/Tk-Clock 77 | bugtracker: https://github.com/Tux/Tk-Clock/issues 78 | meta-spec: 79 | version: 1.4 80 | url: http://module-build.sourceforge.net/META-spec-v1.4.html 81 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Tk::Clock 2 | Clock widget for Perl/Tk with analog and/or digital display 3 | 4 | DESCRIPTION 5 | A canvas clock widget with both analog and digital represen- 6 | tation of both time and date. 7 | 8 | It is highly configurable for as far as colors and fonts and 9 | the way time and date is displayed. 10 | 11 | The year is displayed in two digits in the default configu- 12 | ration, which makes it not Y2K compliant. 13 | 14 | COPYING: 15 | Copyright (c) 1998-2024 H.Merijn Brand. All rights reserved. 16 | 17 | This program is free software; you can redistribute it and/or 18 | modify it under the same terms as Perl itself. 19 | 20 | Recent changes can be (re)viewed in the public GIT repository 21 | at https://github.com/Tux/Tk-Clock 22 | Feel free to clone your own copy: 23 | 24 | $ git clone https://github.com/Tux/Tk-Clock Tk-Clock 25 | 26 | or get it as a tgz: 27 | 28 | $ wget --output-document=Tk-Clock-git.tgz \ 29 | https://github.com/Tux/Tk-Clock/archive/master.tar.gz 30 | 31 | PREREQUISITES 32 | perl5 (probably 5.004.04 or better) 33 | Tk (probably 400.xxx or better) 34 | 35 | This port was tested on several OS's with perl-5.8.8-dor, 36 | perl-5.8.7-dor, and perl-5.8.5-dor in 32bit and 64bit builds 37 | all with Tk-804.027. 38 | 39 | BUILDING AND INSTALLATION 40 | As all CPAN modules: 41 | # perl Makefile.PL 42 | # make test 43 | # make install 44 | 45 | make test should run the clock with some changing contrasting 46 | colors showing the following configurations for 4 seconds each: 47 | 1. Both analog and digital clock, 48 | 2. Only analog clock, 49 | 3. Only digital clock, 50 | 4. Both analog- and digital clock using an american like 51 | time/date format (for wich I shouldn't actualy support 52 | formats, cause amaricans do often not support european 53 | formats, but I thought, I'd be nice for this time), 54 | 5. Only digital clock with an empty time format and a 55 | double line date format showing the day of the week 56 | and the date. 57 | 58 | BUGS 59 | Probably a few. One of them is that if you change the clock 60 | too often with ->config (), some elements might not be moved 61 | correctly, like getting a clock with 5 hands :) 62 | 63 | CHANGES 64 | See ChangeLog 65 | 66 | COPYRIGHT AND LICENSE 67 | Copyright (C) 1998-2024 H.Merijn Brand 68 | 69 | This library is free software; you can redistribute it and/or modify 70 | it under the same terms as Perl itself. 71 | 72 | As always, have the appropriate amount of fun! 73 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright PROCURA B.V. (c) 1999-2024 H.Merijn Brand 4 | 5 | require 5.006; 6 | 7 | use strict; 8 | 9 | # Be kind to testers, not verbose 10 | if (exists $ENV{AUTOMATED_TESTING} and $ENV{AUTOMATED_TESTING}) { 11 | $ENV{DISPLAY} or exit 0; 12 | } 13 | 14 | use ExtUtils::MakeMaker; 15 | 16 | my %wm = ( 17 | NAME => "Tk::Clock", 18 | DISTNAME => "Tk-Clock", 19 | AUTHOR => "H.Merijn Brand ", 20 | VERSION_FROM => "Clock.pm", 21 | ABSTRACT_FROM => "Clock.pm", 22 | 23 | PREREQ_PM => { "Tk" => "402.000", 24 | "Tk::Canvas" => 0, 25 | "Tk::Derived" => 0, 26 | "Tk::Widget" => 0, 27 | "Carp" => 0, 28 | "Test::More" => 0.90, 29 | "Test::NoWarnings" => 0, 30 | "Encode" => 0, 31 | "POSIX" => 0, 32 | }, 33 | 34 | dist => { COMPRESS => "gzip -9f", 35 | SUFFIX => ".gz", 36 | }, 37 | macro => { TARFLAGS => "--format=ustar -c -v -f", 38 | }, 39 | ); 40 | $ExtUtils::MakeMaker::VERSION > 6.30 and $wm{LICENSE} = "perl"; 41 | 42 | my $rv = WriteMakefile (%wm); 43 | 44 | 1; 45 | 46 | package MY; 47 | 48 | sub postamble { 49 | my $valgrind = join " ", qw( 50 | PERL_DESTRUCT_LEVEL=2 PERL_DL_NONLAZY=1 51 | valgrind 52 | --suppressions=sandbox/perl.supp 53 | --leak-check=yes 54 | --leak-resolution=high 55 | --show-reachable=yes 56 | --num-callers=50 57 | --log-fd=3 58 | $(FULLPERLRUN) "-MExtUtils::Command::MM" "-e" 59 | "test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')" 60 | $(TEST_FILES) 3>valgrind.log 61 | ); 62 | 63 | my $min_vsn = ($] >= 5.010 && -d "xt" && -d "sandbox" && ($ENV{AUTOMATED_TESTING} || 0) != 1) 64 | ? join "\n" => 65 | 'test ::', 66 | ' -@env TEST_FILES="xt/*.t" make -e test_dynamic', 67 | '' 68 | : ""; 69 | join "\n" => 70 | 'cover test_cover:', 71 | ' ccache -C', 72 | ' cover -test', 73 | '', 74 | 'leakcheck:', 75 | " $valgrind", 76 | ' -@tail -5 valgrind.log', 77 | '', 78 | 'leaktest:', 79 | q{ sandbox/leaktest $(FULLPERLRUN) "test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')" $(TEST_FILES)}, 80 | '', 81 | 'spellcheck: doc', 82 | ' pod-spell-check --aspell', 83 | '', 84 | 'checkmeta: spellcheck', 85 | ' perl sandbox/genMETA.pl -c', 86 | '', 87 | 'fixmeta: distmeta', 88 | ' perl sandbox/genMETA.pl', 89 | ' ls -l */META.yml', 90 | '', 91 | 'tgzdist: checkmeta fixmeta $(DISTVNAME).tar.gz distcheck', 92 | ' -@mv -f $(DISTVNAME).tar.gz $(DISTVNAME).tgz', 93 | ' -@cpants_lint.pl $(DISTVNAME).tgz', 94 | ' -@rm -f Debian_CPANTS.txt', 95 | '', 96 | 'doc docs: doc/Clock.md doc/Clock.html doc/Clock.man', 97 | ' -@rm -f pod2html.tmp', 98 | 'doc/Clock.md: Clock.pm', 99 | ' pod2markdown < $? > $@', 100 | 'doc/Clock.html: Clock.pm', 101 | ' pod2html < $? 2>&1 | grep -v "^Cannot find" > $@', 102 | 'doc/Clock.3: Clock.pm', 103 | ' pod2man < $? > $@', 104 | 'doc/Clock.man: doc/Clock.3', 105 | ' nroff2man < $? > $@', 106 | '', 107 | $min_vsn; 108 | } # postamble 109 | 110 | 1; 111 | -------------------------------------------------------------------------------- /t/30_dual.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | require Test::NoWarnings; 8 | 9 | BEGIN { 10 | use_ok ("Tk"); 11 | use_ok ("Tk::Clock"); 12 | } 13 | 14 | my ($delay, $period, $m, $c) = (0, $ENV{TK_TEST_LENGTH} || 5000); 15 | unless ($m = eval { MainWindow->new (-title => "clock", -background => "Black") }) { 16 | diag ("No valid Tk environment"); 17 | done_testing; 18 | exit 0; 19 | } 20 | 21 | my %defconfig = ( 22 | -background => "Black", 23 | 24 | useDigital => 1, 25 | autoScale => 1, 26 | useAnalog => 1, 27 | useInfo => 1, 28 | ana24hour => 0, 29 | secsColor => "Green", 30 | tickColor => "Blue", 31 | tickFreq => 1, 32 | timeFont => "{fixed} 11", 33 | timeColor => "lightBlue", 34 | timeFormat => "HH:MM:SS", 35 | dateFont => "{fixed} 11", 36 | dateColor => "#cfb53b", 37 | infoFont => "{Helvetica} 11 bold", 38 | time2TZ => "UTC", 39 | time2Color => "White", 40 | time2Font => "{fixed} 12", 41 | # time2Format => "HH:MM:SS", 42 | ); 43 | 44 | ok (my $c1 = $m->Clock (%defconfig), "Clock Local TimeZone"); 45 | like ($c1->config (( 46 | anaScale => 200, 47 | infoFormat => "Omega", 48 | handColor => "Red", 49 | timeZone => $ENV{TZ} || undef, 50 | dateFormat => "Local", 51 | useText => 1, 52 | textFormat => "\x{03a9}", 53 | textColor => "Blue", 54 | )), qr(^Tk::Clock=HASH), "config"); 55 | ok ($c1->grid (-column => 0, -row => 0, -sticky => "news"), "grid"); 56 | 57 | ok (my $c2 = $m->Clock (%defconfig), "Clock GMT"); 58 | like ($c2->config ( 59 | anaScale => 200, 60 | infoFormat => "Hc:Mc:Sc", 61 | infoFont => "{DejaVu Sans} 10", 62 | timerValue => 12345, # 04:25:45 63 | handColor => "Orange", 64 | timeZone => "GMT", 65 | dateFormat => "London (GMT)", 66 | useText => 1, 67 | textFormat => "\x{23f0}", 68 | ), qr(^Tk::Clock=HASH), "config"); 69 | ok ($c2->grid (-column => 0, -row => 1, -sticky => "news", -padx => 20), "grid"); 70 | 71 | ok (my $c3 = $m->Clock (%defconfig), "Clock MET-1METDST"); 72 | like ($c3->config ( 73 | anaScale => 200, 74 | infoFormat => "HH:MM:SS", 75 | handColor => "Yellow", 76 | timeZone => "MET-1METDST", 77 | dateFormat => "Amsterdam (MET)", 78 | ), qr(^Tk::Clock=HASH), "config"); 79 | ok ($c3->grid (-column => 1, -row => 0, -sticky => "news", -pady => 20), "grid"); 80 | 81 | ok (my $c4 = $m->Clock (%defconfig), "Clock Tokyo"); 82 | like ($c4->config ( 83 | anaScale => 200, 84 | countDown => 1, 85 | useLocale => ($^O eq "MSWin32" ? "Japanese_Japan.932" : "ja_JP.utf8"), 86 | infoFormat => "ddd mmm", 87 | handColor => "Yellow", 88 | timeZone => "Asia/Tokyo", 89 | dateFormat => "Asia/Tokyo", 90 | ), qr(^Tk::Clock=HASH), "config"); 91 | ok ($c4->grid (-column => 1, -row => 1, -sticky => "news", -padx => 20, -pady => 20), "grid"); 92 | 93 | for (0..1) { 94 | $m->gridColumnconfigure ($_, -weight => 1); 95 | $m->gridRowconfigure ($_, -weight => 1); 96 | } 97 | 98 | $delay += 5 * $period; 99 | $c3->after ($delay, sub { 100 | $_->destroy for $c1, $c2, $c3, $c4; 101 | ok (!Exists ($_), "Destroy Clock") for $c1, $c2, $c3, $c4; 102 | $m->destroy; 103 | ok (!Exists ($m), "Destroy Main"); 104 | 105 | Test::NoWarnings::had_no_warnings (); 106 | done_testing; 107 | }); 108 | 109 | MainLoop; 110 | -------------------------------------------------------------------------------- /examples/cdclock.pl: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Tk; 7 | use Tk::Clock; 8 | 9 | my @bw = reverse qw( Black White ); 10 | 11 | my $m = MainWindow->new; 12 | 13 | $m->configure ( 14 | -foreground => $bw[0], 15 | -background => $bw[1], 16 | ); 17 | 18 | my $face = $^O =~ m/mswin/i ? "Arial" : "DejaVu Sans Mono"; 19 | 20 | my $c = $m->Clock ( 21 | -background => $bw[1], 22 | -relief => "flat", 23 | )->pack ( 24 | -expand => 1, 25 | -fill => "both", 26 | -padx => 30, 27 | -pady => 30, 28 | -side => "left", 29 | ); 30 | $c->config ( 31 | useDigital => 0, 32 | useInfo => 1, 33 | useAnalog => 1, 34 | secsColor => "Red", 35 | handColor => $bw[0], 36 | tickColor => $bw[0], 37 | tickFreq => 1, 38 | tickDiff => 1, 39 | handCenter => 1, 40 | anaScale => 800, 41 | autoScale => 1, 42 | infoFormat => "", 43 | infoFont => "{$face} 48", 44 | infoColor => "Gray10", 45 | ); 46 | 47 | my ($l, $rest, $end, $secs, $left) = (""); 48 | 49 | sub rest { 50 | use integer; 51 | my $now = time; 52 | 53 | unless (defined $end) { 54 | $rest = ""; 55 | $secs = ""; 56 | $left = ""; 57 | $end = undef; 58 | return; 59 | } 60 | 61 | $now > $end and return; 62 | 63 | $secs = $end - $now; 64 | $rest = int (($secs + 10) / 60); 65 | 66 | $l->configure ( 67 | -background => "Black", 68 | -foreground => 69 | $rest > 5 ? "Green4" : 70 | $rest > 3 ? "Yellow" : 71 | $secs > 60 ? "Orange" : "Red"); 72 | 73 | $left = sprintf "%02d:%02d", $secs / 60, $secs % 60; 74 | $c->config (infoFormat => $left); 75 | $secs == 60 and $l->bell for 1..2; 76 | $secs < 60 and $rest = $secs; 77 | 78 | if ($rest) { 79 | $l->after (100, \&rest); 80 | return; 81 | } 82 | 83 | $l->bell for 1..10; 84 | $l->configure (-background => "Red"); 85 | $l->after (30000, sub { $l->configure (-background => "Black") }); 86 | $c->config (infoFormat => ""); 87 | $rest = ""; 88 | $end = undef; 89 | } # rest 90 | 91 | sub start { 92 | my $val = 60 * shift; 93 | $end = time + $val; 94 | rest (); 95 | } # start 96 | 97 | my $f = $m->Frame (-background => "Black")->pack ( 98 | -expand => 1, 99 | -padx => 30, 100 | -pady => 30, 101 | -fill => "both", 102 | -side => "left", 103 | ); 104 | 105 | $l = $f->Label ( 106 | -textvariable => \$rest, 107 | -font => "{$face} 200 bold", 108 | -background => "Black", 109 | )->pack (-expand => 1, -side => "top", -fill => "both", -anchor => "c"); 110 | 111 | my $g = $f->Frame (-background => "Black")->pack ( 112 | -side => "bottom", -anchor => "se", -fill => "x"); 113 | my $ctrl = $g->Frame (-background => "Black")->pack ( 114 | -side => "bottom", -anchor => "se", -fill => "x"); 115 | my $smll = $g->Frame (-background => "Black")->pack ( 116 | -side => "top", -anchor => "s", -fill => "x"); 117 | 118 | $smll->Label ( 119 | -textvariable => \$secs, 120 | -background => "Black", 121 | -foreground => "Yellow", 122 | -anchor => "sw", 123 | )->pack (-side => "left", -anchor => "w"); 124 | $smll->Label ( 125 | -textvariable => \$left, 126 | -background => "Black", 127 | -foreground => "Yellow", 128 | -anchor => "se", 129 | )->pack (-side => "right", -anchor => "e"); 130 | 131 | my %bo = ( 132 | -borderwidth => 1, 133 | -highlightthickness => 1, 134 | -relief => "flat", 135 | -activebackground => "Gray10", 136 | -activeforeground => "Red2", 137 | -highlightcolor => "Red2", 138 | -background => "Black", 139 | -foreground => "Red2", 140 | ); 141 | for (1 .. 6) { 142 | my $d = 5 * $_; 143 | $ctrl->Button (%bo, 144 | -text => $d, 145 | -font => "fixed", 146 | -command => sub { start ($d) }, 147 | )->grid (-row => 0, -column => $_ - 1, -sticky => "news"); 148 | } 149 | 150 | $ctrl->Button (%bo, 151 | -text => " 0", 152 | -font => "fixed", 153 | -command => sub { $end = undef; rest (); }, 154 | )->grid (-row => 1, -column => 0, -sticky => "news"); 155 | $ctrl->Button (%bo, 156 | -text => "-1", 157 | -font => "fixed", 158 | -command => sub { defined $end and $end -= 60; }, 159 | )->grid (-row => 1, -column => 1, -sticky => "news"); 160 | $ctrl->Button (%bo, 161 | -text => "-\x{00bd}", 162 | -font => "fixed", 163 | -command => sub { defined $end and $end -= 30; }, 164 | )->grid (-row => 1, -column => 2, -sticky => "news"); 165 | $ctrl->Button (%bo, 166 | -text => "+\x{00bd}", 167 | -font => "fixed", 168 | -command => sub { defined $end and $end += 30; }, 169 | )->grid (-row => 1, -column => 3, -sticky => "news"); 170 | $ctrl->Button (%bo, 171 | -text => "+1", 172 | -font => "fixed", 173 | -command => sub { defined $end and $end += 60; }, 174 | )->grid (-row => 1, -column => 4, -sticky => "news"); 175 | $ctrl->Button (%bo, 176 | -text => "XX", 177 | -font => "fixed", 178 | -command => sub { exit; }, 179 | )->grid (-row => 1, -column => 5, -sticky => "news"); 180 | 181 | $ctrl->gridColumnconfigure ($_, -weight => 1) for 0..5; 182 | 183 | MainLoop; 184 | -------------------------------------------------------------------------------- /t/10_base.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | require Test::NoWarnings; 8 | 9 | BEGIN { 10 | use_ok ("Tk"); 11 | use_ok ("Tk::Clock"); 12 | } 13 | 14 | my ($delay, $period, $m, $c) = (0, $ENV{TK_TEST_LENGTH} || 5000); 15 | unless ($m = eval { MainWindow->new (-title => "clock") }) { 16 | diag ("No valid Tk environment"); 17 | done_testing; 18 | exit 0; 19 | } 20 | 21 | ok ($c = $m->Clock (-background => "Black"), "Clock Widget"); 22 | 23 | # Safe to use en_US.UTF-8, as the fallback is C and all values are the same 24 | foreach my $loc ("C", "en_US.UTF-8") { 25 | is (Tk::Clock::_month ($loc, 0, 0), "1", "Month format m Jan in $loc"); 26 | is (Tk::Clock::_month ($loc, 2, 1), "03", "Month format mm Mar in $loc"); 27 | is (Tk::Clock::_month ($loc, 4, 2), "May", "Month format mmm May in $loc"); 28 | is (Tk::Clock::_month ($loc, 6, 3), "July", "Month format mmmm Jul in $loc"); 29 | 30 | is (Tk::Clock::_wday ($loc, 0, 0), "Sun", "Weekday format ddd Sun in $loc"); 31 | is (Tk::Clock::_wday ($loc, 2, 1), "Tuesday", "Weekday format dddd Tue in $loc"); 32 | } 33 | 34 | like ($c->config ( 35 | tickColor => "Orange", 36 | handColor => "Red", 37 | secsColor => "Green", 38 | timeColor => "lightBlue", 39 | dateColor => "Gold", 40 | timeFont => "Helvetica 6", 41 | dateFont => "Helvetica 6", 42 | ), qr(^Tk::Clock=HASH), "config"); 43 | ok ($c->pack (-expand => 1, -fill => "both"), "pack"); 44 | # Three stupid tests to align the rest 45 | is ($delay, 0, "Delay is 0"); 46 | like ($period, qr/^\d+$/, "Period is $period"); 47 | 48 | $delay += $period; 49 | like ($delay, qr/^\d+$/, "First after $delay"); 50 | 51 | $c->after ($delay, sub { 52 | $c->configure (-background => "Blue4"); 53 | ok ($c->config ( 54 | tickColor => "Yellow", 55 | useAnalog => 1, 56 | useInfo => 0, 57 | useDigital => 0, 58 | ), "Blue4 Ad Yellow"); 59 | }); 60 | 61 | $delay += $period; 62 | $c->after ($delay, sub { 63 | $c->configure (-background => "Tan4"); 64 | ok ($c->config ( 65 | useAnalog => 0, 66 | useInfo => 0, 67 | useDigital => 1, 68 | ), "Tan4 aD"); 69 | }); 70 | 71 | $delay += $period; 72 | $c->after ($delay, sub { 73 | $c->configure (-background => "Maroon4"); 74 | ok ($c->config ( 75 | useAnalog => 1, 76 | useInfo => 1, 77 | useDigital => 4, # Should be normalized to 1 78 | dateFormat => "m/d/y", 79 | timeFormat => "hh:MM A", 80 | _digSize => 800, # Should be ignored 81 | ), "Maroon4 AD m/d/y hh:MM A"); 82 | }); 83 | 84 | $delay += $period; 85 | $c->after ($delay, sub { 86 | $c->configure (-background => "Red4"); 87 | ok ($c->config ( 88 | useAnalog => 0, 89 | useInfo => 0, 90 | useDigital => 1, 91 | dateFormat => "mmm yyy", 92 | timeFormat => "HH:MM:SS", 93 | ), "Red4 aD mmm yyy HH:MM:SS"); 94 | }); 95 | 96 | $delay += $period; 97 | $c->after ($delay, sub { 98 | $c->configure (-background => "Gray10"); 99 | ok ($c->config ( 100 | useAnalog => 1, 101 | useInfo => 1, 102 | useDigital => 1, 103 | digiAlign => "right", 104 | ), "Gray10 right digital"); 105 | }); 106 | 107 | $delay += $period; 108 | $c->after ($delay, sub { 109 | $c->configure (-background => "Gray30"); 110 | ok ($c->config ( 111 | useAnalog => 1, 112 | useInfo => 0, 113 | useDigital => 1, 114 | digiAlign => "left", 115 | ), "Gray30 left digital"); 116 | }); 117 | 118 | $delay += $period; 119 | $c->after ($delay, sub { 120 | $c->configure (-background => "Purple4"); 121 | ok ($c->config ( 122 | useAnalog => 0, 123 | useInfo => 0, 124 | useDigital => 1, 125 | useLocale => ($^O eq "MSWin32" ? "Japanese_Japan.932" : "ja_JP.utf8"), 126 | timeFont => "Helvetica 8", 127 | dateFont => "Helvetica 8", 128 | dateFormat => "dddd\nd mmm yyy", 129 | timeFormat => "", 130 | ), "Purple4 aD dddd\\nd mmm yyy ''"); 131 | }); 132 | 133 | $delay += $period; 134 | $c->after ($delay, sub { 135 | $c->configure (-background => "Gray75"); 136 | ok ($c->config ( 137 | useAnalog => 1, 138 | useInfo => 1, 139 | useDigital => 0, 140 | anaScale => 300, 141 | timeFont => "Helvetica 12", 142 | dateFont => "Helvetica 12", 143 | infoFormat => "Tk-Clock", 144 | ), "Gray75 Ad scale 300"); 145 | }); 146 | 147 | $delay += $period; 148 | $c->after ($delay, sub { 149 | ok ($c->config ( 150 | useAnalog => 1, 151 | useInfo => 0, 152 | useDigital => 0, 153 | anaScale => 67, 154 | tickFreq => 5, 155 | ), " Ad scale 67 tickFreq 5"); 156 | }); 157 | 158 | $delay += $period; 159 | $c->after ($delay, sub { 160 | ok ($c->config ( 161 | useAnalog => 1, 162 | useInfo => 0, 163 | useDigital => 1, 164 | anaScale => 100, 165 | tickFreq => 5, 166 | dateFormat => "ww dd-mm", 167 | timeFormat => "dd HH:SS", 168 | ), " AD scale 100 tickFreq 5 ww dd-mm dd HH:SS"); 169 | }); 170 | 171 | $delay += $period; 172 | $c->after ($delay, sub { 173 | ok ($c->config ({ 174 | anaScale => 150, 175 | dateFont => "Helvetica 9", 176 | }), " Increase date font size"); 177 | }); 178 | 179 | $delay += $period; 180 | $c->after ($delay, sub { 181 | $c->configure (-background => "Black"); 182 | ok ($c->config ({ 183 | anaScale => 250, 184 | useAnalog => 1, 185 | useInfo => 0, 186 | useDigital => 0, 187 | secsColor => "Red", 188 | tickColor => "White", 189 | handColor => "White", 190 | handCenter => 1, 191 | tickFreq => 1, 192 | tickDiff => 1, 193 | }), " Station clock: hand centers and tick width"); 194 | }); 195 | 196 | $delay += $period; 197 | $c->after ($delay, sub { 198 | $c->configure (-background => "Black"); 199 | ok ($c->config ({ 200 | useInfo => 1, 201 | useDigital => 1, 202 | anaScale => 300, 203 | dateFormat => "dd-mm-yyyy", 204 | timeFormat => "HH:MM:SS", 205 | localOffset => -363967, # minus 4 days, 5 hours, 6 minutes and 7 seconds 206 | }), " Station clock: Time offset -4'05:06:07"); 207 | }); 208 | 209 | $delay += $period; 210 | $c->after ($delay, sub { 211 | $c->destroy; 212 | ok (!Exists ($c), "Destroy Clock"); 213 | $m->destroy; 214 | ok (!Exists ($m), "Destroy Main"); 215 | 216 | Test::NoWarnings::had_no_warnings (); 217 | done_testing; 218 | }); 219 | 220 | MainLoop; 221 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | 0.45 - 31 Oct 2024, H.Merijn Brand 2 | * Refine requirements based on CVE's 3 | * Work around groff-1.24 4 | * It's 2024 5 | * Missing ; in doc example 6 | * Tested on perl-5.40 7 | * Added textInfo / useText 8 | * Added time2* with own timeZone 9 | 10 | 0.44 - 06 Jan 2023, H.Merijn Brand 11 | * It's 2023 12 | 13 | 0.43 - 01 Jan 2022, H.Merijn Brand 14 | * It's 2021 - no changes in 2021 15 | * It's 2022 16 | 17 | 0.42 - 23 Dec 2020, H.Merijn Brand 18 | * Ignore leading dash in config 19 | * Fix META issue for bugtracker 20 | 21 | 0.41 - 09 Apr 2020, H.Merijn Brand 22 | * It's 2017 23 | * It's 2018 24 | * Document TAGS 25 | * It's 2019 26 | * Add cpanfile 27 | * It's 2020 28 | 29 | 0.40 - 12 May 2016, H.Merijn Brand 30 | * Fix backdrop test 31 | * Add CONTRIBUTING.md 32 | * It's 2016 33 | * Tested with 5.24.0, blead and Tk (git) 34 | 35 | 0.39 - 12 Feb 2015, H.Merijn Brand 36 | * Move repo to github 37 | * Remove perl recommendation from META as it breaks cpan clients 38 | 39 | 0.38 - 03 Jan 2015, H.Merijn Brand 40 | * Fix skip_all. require Test::More 0.88 41 | 42 | 0.37 - 02 Jan 2015, H.Merijn Brand 43 | * Use 12:15 AM instead of 00:15 AM 44 | * Upped Copyright to 2015 45 | 46 | 0.36 - 10 Apr 2014, H.Merijn Brand 47 | * Fix locales for non-utf8 (and windows) 48 | * Upped Copyright to 2014 49 | * Make sure boolean attributes are 0 or 1 50 | * Protect internal attributes from new and config calls 51 | * Dynamically determine width of digital date and time 52 | 53 | 0.35 - 20 Aug 2013, H.Merijn Brand 54 | * Indented SYNOPSIS (RT#85697 - Djibril Ousmanou) 55 | * Support for locales in long day and month formats 56 | * Support for local offset (in seconds) 57 | 58 | 0.34 - 28 May 2013, H.Merijn Brand 59 | * Force update if time wound back (ntp, date command) 60 | * Upped Copyright to 2013 61 | * Forced order of config attributes (destroying attribs last) 62 | 63 | 0.33 - 17 Apr 2012, H.Merijn Brand 64 | * Upped Copyright to 2012 65 | * Better protect against CPANTESTERS with non-Tk environment 66 | 67 | 0.32 - 07 Sep 2011, H.Merijn Brand 68 | * NAME / DISTNAME in Makefile.PL 69 | 70 | 0.31 - 07 Sep 2011, H.Merijn Brand 71 | * More cross-checks for META data 72 | 73 | 0.30 - 12 May 2011, H.Merijn Brand 74 | * Initialization fix (attributes can be passed to constructor as it has 75 | always be intended) 76 | * Upped Copyright to 2011 77 | 78 | 0.29 - 02 Aug 2010, H.Merijn Brand 79 | * Spell-checking 80 | * Added useInfo, infoColor, infoFormat, and infoFont 81 | * timeFormat, dateFormat and infoFormat now all support all abbreviations 82 | * Added timerValue and corresponding Hc, Mc, and Sc format entries 83 | 84 | 0.28 - 16 Mar 2010, H.Merijn Brand 85 | * Allow to change backdrop while running 86 | * Upped Copyright to 2010 87 | * Dropped YAML spec to 1.0 88 | 89 | 0.27 - 18 May 2009, H.Merijn Brand 90 | * Enabled backdrop 91 | * Add useSecHand option 92 | * Overhauled the documentation 93 | 94 | 0.26 - 20 Mar 2009, H.Merijn Brand 95 | * replace ->_packMethod () with ->manager 96 | * t/30_dual.t now allows resizing in grid 97 | * examples/cdclock.pl now acts as I had in mind 98 | * Added Test::NoWarnings 99 | 100 | 0.25 - 08 Mar 2009, H.Merijn Brand 101 | * Vastly improved on resizing. 102 | * Prefer autoScale => 1 over anaScale => 0 103 | * Add examples/cdclock.pl (Lightning Talk countdown clock) 104 | 105 | 0.24 - 20 Jan 2009, H.Merijn Brand 106 | * Wrong e-mail in META.yml 107 | * Copyright 2009 108 | * Guard cpantesters with $DISPLAY unset 109 | 110 | 0.23 - 21 Oct 2008, H.Merijn Brand 111 | * Added tgzdist make target 112 | * Slightly changed the cover make target 113 | * Allow yyyy in date formats 114 | * Add `weird' TimeZones to examples/world.pl 115 | * examples/station.pl can have reversed colors, is resizeable, 116 | and the ticks don't touch the edges 117 | 118 | 0.22 - 02 Jan 2008, H.Merijn Brand 119 | * Tk::Clock is now under git 120 | * Upped copyright to 2008 121 | * Added complete prereq list to Makefile.PL 122 | 123 | 0.21 - 09 Nov 2007, H.Merijn Brand 124 | * Added tickDiff attribute for width-diff of the ticks 125 | * Added handCenter attribute (see examples/station.pl) 126 | * Added examples/station.pl (Stations klok) 127 | * Added countDown attribute and examples/countdown.pl 128 | * Fixed auto-resize for clocks with digital disabled 129 | * Tested with Tk-804.027_501+ 130 | 131 | 0.20 - 08 Oct 2007, H.Merijn Brand 132 | * Added a 7-clocks wide example/world.pl 133 | * And fixed the Time Zones in world.pl 134 | * Raised requirement to 5.006, as I use our and recent Tk builds 135 | require 5.007 136 | 137 | 0.19 - 08 May 2007, H.Merijn Brand 138 | * LICENSE entry for MakeMaker only for newer versions 139 | * Updated plans/TODO 140 | * Updated Copyrights 141 | * Moved pod to bottom 142 | * Added timeZone support! 143 | * Split up tests 144 | * Loosened up the dateFormat and timeFormat attributes to 145 | allow fixed text. Needs documentation! 146 | * Added a test with three clocks side-by-side with different TZ's 147 | 148 | 0.18 - 27 Apr 2007, H.Merijn Brand 149 | * Added cover make target 150 | * Added auto-resize test. Still depends on user doing the resize 151 | * Increased coverage. More coverage is doable, but it'll be a 152 | booooring job to wait for the tests to finish 153 | 154 | 0.17 - 16 Nov 2006, H.Merijn Brand 155 | * Missed one '.' in the format change (K.Wittrock) 156 | * secsColor was missed in config attrib handling 157 | * allow both -secsColor and secsColor 158 | 159 | 0.16 - 17 Oct 2006, H.Merijn Brand 160 | * Default format for time HH.MM:SS => HH:MM:SS (wish K.Wittrock) 161 | * Added digiAlign option. Default: "center" (wish K.Wittrock) 162 | * $clock->coords (...) now used for the hands instead of 163 | deleting and (re)creating them (suggestion K.Wittrock) 164 | 165 | 0.15 - 18 Sep 2005, H.Merijn Brand 166 | * Added Test::Pod 167 | * Added Test::Pod::Coverage 168 | 169 | 0.12 - 31 Aug 2005, H.Merijn Brand 170 | * 24 Hour clock for Abe 171 | * config () now returns the widget, so it's stackable 172 | 173 | 0.11 - 14 Aug 2005, H.Merijn Brand 174 | * Resize reconfigured wrong widget 175 | 176 | 0.10 - 11 Aug 2005, H.Merijn Brand 177 | * Solved digital clock misplacement when anaScale passed (Abeltje) 178 | * Improved resizing 179 | * Set geometry of parent if MainWindow 180 | * Changed README and updated Copyright 181 | * Added a warning for resizing and pack 182 | * Changed the tests to use Test::More 183 | * config now returns the widgets new geometry 184 | 185 | 0.07 - 03 Apr 2000, H.Merijn Brand 186 | * Added 'w' and 'ww' for weeknumbers in dateFormat 187 | * Added 'd' and 'dd' for day of the week in timeFormat (for Henry) 188 | 189 | 0.06 - 27 Sep 1999, H.Merijn Brand 190 | * Analog clock now scalable (anaScale) 191 | * Number of ticks configurable (tickFreq) 192 | 193 | 0.05 - 07 Apr 1999, H.Merijn Brand 194 | * Updated the README 195 | * Implemented ddd, dddd, mmm, mmmm (English only) 196 | * Enabled \n in date format. If combined with empty time 197 | format, formats like "dddd\nd mmm yyyy" can be used. 198 | 199 | 0.04 - 15 Dec 1998, H.Merijn Brand 200 | * Changed README according to perlmodlib manpage 201 | * Made date formats more Y2K reliable 202 | dd-mm-yyy still doesn't fit in the allocated space 203 | 204 | 0.03 - 26 Aug 1998, H.Merijn Brand 205 | * Analog/Digital part can be disabled. 206 | 207 | 0.02 - 22 Jul 1998, H.Merijn Brand 208 | * Support date/time formats through config 209 | 210 | 0.01 - 20 Jul 1998, H.Merijn Brand 211 | * First attempt to get it on the CPAN 212 | * Added config () 213 | * minimized update of the text fields 214 | 215 | 0.00 - 09 Jun 1998, H.Merijn Brand 216 | * First post to Achim, as excerpt from xamen.pl 217 | -------------------------------------------------------------------------------- /doc/Clock.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | Tk::Clock - Clock widget with analog and digital display 4 | 5 | # SYNOPSIS 6 | 7 | use Tk; 8 | use Tk::Clock; 9 | 10 | $clock = $parent->Clock (?-option => ...?); 11 | 12 | $clock->config ( # These reflect the defaults 13 | timeZone => "", 14 | useLocale => "C", 15 | backDrop => "", 16 | 17 | useAnalog => 1, 18 | handColor => "Green4", 19 | secsColor => "Green2", 20 | tickColor => "Yellow4", 21 | tickFreq => 1, 22 | tickDiff => 0, 23 | useSecHand => 1, 24 | handCenter => 0, 25 | anaScale => 100, 26 | autoScale => 0, 27 | ana24hour => 0, 28 | countDown => 0, 29 | timerValue => 0, 30 | localOffset => 0, 31 | 32 | useInfo => 0, 33 | infoColor => "#cfb53b", 34 | infoFormat => "HH:MM:SS", 35 | infoFont => "fixed 6", 36 | useText => 0, 37 | textColor => "#c4c4c4", 38 | textFormat => "HH:MM:SS", 39 | textFont => "fixed 6", 40 | time2Font => "fixed 6", 41 | time2Color => "Red4", 42 | time2Format => "HH:MM:SS", 43 | time2TZ => "Europe/Amsterdam", 44 | 45 | useDigital => 1, 46 | digiAlign => "center", 47 | timeFont => "fixed 6", 48 | timeColor => "Red4", 49 | timeFormat => "HH:MM:SS", 50 | dateFont => "fixed 6", 51 | dateColor => "Blue4", 52 | dateFormat => "dd-mm-yy", 53 | ); 54 | 55 | # DESCRIPTION 56 | 57 | This module implements a Canvas-based clock widget for perl-Tk with lots 58 | of options to change the appearance. 59 | 60 | Both analog and digital clocks are implemented. 61 | 62 | # METHODS 63 | 64 | ## Clock 65 | 66 | This is the constructor. It does accept the standard widget options plus those 67 | described in ["config"](#config). 68 | 69 | ## config 70 | 71 | Below is a description of the options/attributes currently available. Their 72 | default value is in between parenthesis. 73 | 74 | - useAnalog (1) 75 | - useInfo (0) 76 | - useText (0) 77 | - useDigital (1) 78 | 79 | Enable the analog clock (`useAnalog`) and/or the digital clock (`useDigital`) 80 | in the widget. The analog clock will always be displayed above the digital part 81 | 82 | +----------+ ...... 83 | | .. | \ . \ | . 84 | | . \_ . | |_ Analog clock . Tim2 . 85 | | . . | | . * . 86 | | .. | / . Info . 87 | | 23:59:59 | --- Digital time . Text . 88 | | 31-12-09 | --- Digital date ...... 89 | +----------+ 90 | 91 | The analog clock displays ticks, hour hand, minutes hand and second hand. 92 | The digital part displays two parts, which are configurable. By default 93 | these are time and date. 94 | 95 | The `useInfo` enables a text field between the backdrop of the analog 96 | clock and its items. You can use this field to display personal data. 97 | 98 | The `useText` is like second line of `useInfo`, but with support for 99 | callbacks or variable binding. 100 | 101 | $clock->configure (useText => 1, textFormat => \$foo); 102 | $clock->configure (useText => 1, textFormat => sub { int rand 42 }); 103 | 104 | - autoScale (0) 105 | 106 | When set to a true value, the widget will try to re-scale itself to 107 | automatically fit the containing widget. 108 | 109 | $clock->config (autoScale => 1); 110 | 111 | - anaScale (100) 112 | 113 | The analog clock can be enlarged or reduced using anaScale for which 114 | the default of 100% is about 72x72 pixels. 115 | 116 | When using `pack` for your geometry management, be sure to pass 117 | `-expand => 1, -fill => "both"` if you plan to resize with 118 | `anaScale` or enable/disable either analog or digital after the 119 | clock was displayed. 120 | 121 | $clock->config (anaScale => 400); 122 | 123 | - ana24hour (0) 124 | 125 | The default for the analog clock it the normal 12 hours display, as 126 | most clocks are. This option will show a clock where one round of the 127 | hour-hand will cover a full day of 24 hours, noon is at the bottom 128 | where the 6 will normally display. 129 | 130 | $clock->config (ana24hour => 1); 131 | 132 | - useSecHand (1) 133 | 134 | This controls weather the seconds-hand is shown. 135 | 136 | $clock->config (useSecHand => 0); 137 | 138 | - countDown (0) 139 | 140 | When `countDown` is set to a true value, the clock will run backwards. 141 | This is a slightly experimental feature, it will not count down to a 142 | specific point in time, but will simply reverse the rotation, making 143 | the analog clock run counterclockwise. 144 | 145 | - timerValue (0) 146 | 147 | This represents a countdown timer. 148 | 149 | When setting `timerValue` to a number of seconds, the format values 150 | `Hc`, `Mc`, and `Sc` will represent the hour, minute and second of 151 | the this value. When the time reaches 0, all countdown values are 152 | reset to 0. 153 | 154 | - localOffset (0) 155 | 156 | The value of this attribute represents the local offset for this clock 157 | in seconds. Negative is back in time, positive is in the future. 158 | 159 | # Wind back clock 4 days, 5 hours, 6 minutes and 7 seconds 160 | $clock->config (localOffset => -363967); 161 | 162 | - handColor ("Green4") 163 | - secsColor ("Green2") 164 | 165 | Set the color of the hands of the analog clock. `handColor` controls 166 | the color for both the hour-hand and the minute-hand. `secsColor` 167 | controls the color for the seconds-hand. 168 | 169 | $clock->config ( 170 | handColor => "#7F0000", 171 | secsColor => "OrangeRed", 172 | ); 173 | 174 | - handCenter (0) 175 | 176 | If set to a true value, will display a circular extension in the center 177 | of the analog clock that extends the hands as if they have a wider area 178 | at their turning point, like many station-type clocks (at least in the 179 | Netherlands) have. 180 | 181 | $clock->config (handCenter => 1); 182 | 183 | - tickColor ("Yellow4") 184 | 185 | Controls the color of the ticks in the analog clock. 186 | 187 | $clock->config (tickColor => "White"); 188 | 189 | - tickFreq (1) 190 | - tickDiff (0) 191 | 192 | `tickFreq` controls how many ticks are shown in the analog clock. 193 | 194 | Meaningful values for `tickFreq` are 1, 5 and 15 showing all ticks, tick 195 | every 5 minutes or the four main ticks only, though any positive integer 196 | will do (put a tick on any `tickFreq` minute). 197 | 198 | When setting tickDiff to a true value, the major ticks will use a thicker 199 | line than the minor ticks. 200 | 201 | $clock->config ( 202 | tickFreq => 5, 203 | tickDiff => 1, 204 | ); 205 | 206 | - timeZone ("") 207 | 208 | Set the timezone for the widget. The format should be the format recognized 209 | by the system. If unset, the local timezone is used. 210 | 211 | $clock->config (timeZone => "Europe/Amsterdam"); 212 | $clock->config (timeZone => "MET-1METDST"); 213 | 214 | - useLocale ("C") 215 | 216 | Use this locale for the text shown in month formats `mmm` and `mmmm` and in 217 | day formats `ddd` and `dddd`. 218 | 219 | $clock->config (useLocale => $ENV{LC_TIME} // $ENV{LC_ALL} 220 | // $ENV{LANG} // "nl_NL.utf8"); 221 | 222 | See [http://docs.moodle.org/dev/Table\_of\_locales](http://docs.moodle.org/dev/Table_of_locales) for a table of locales 223 | and the Windows equivalents. Windows might not have a UTF8 version available 224 | of the required locale. 225 | 226 | - timeFont ("fixed 6") 227 | 228 | Controls the font to be used for the top line in the digital clock. Will 229 | accept all fonts that are supported in your version of perl/Tk. This includes 230 | both True Type and X11 notation. 231 | 232 | $clock->config (timeFont => "{Liberation Mono} 11"); 233 | 234 | - timeColor ("Red4") 235 | 236 | Controls the color of the first line (time) of the digital clock. 237 | 238 | $clock->config (timeColor => "#00ff00"); 239 | 240 | - timeFormat ("HH:MM:SS") 241 | 242 | Defines the format of the first line of the digital clock. By default it 243 | will display the time in a 24-hour notation. 244 | 245 | Legal `timeFormat` characters are `H` and `HH` for 24-hour, `h` and 246 | `hh` for AM/PM hour, `M` and `MM` for minutes, `S` and `SS` for 247 | seconds, `Hc` for countdown/timer hour, `Mc` for countdown/timer 248 | minutes, `Sc` for countdown/timer seconds, `A` for AM/PM indicator, 249 | `d` and `dd` for day-of-the month, `ddd` and `dddd` for short and 250 | long weekday, `m`, `mm`, `mmm` and `mmmm` for month, `y` and `yy` 251 | for year, `w` and `ww` for week-number and any separators `:`, `-`, 252 | `/` or `space`. 253 | 254 | $clock->config (timeFormat => "hh:MM A"); 255 | 256 | The text shown in the formats `ddd`, `dddd`, `mmm`, and `mmmm` might be 257 | influenced by the setting of `useLocale`. The fallback is locale "C". 258 | 259 | - time2Font ("fixed 6") 260 | 261 | Controls the font to be used for the alternate time in the analog clock. Will 262 | accept all fonts that are supported in your version of perl/Tk. This includes 263 | both True Type and X11 notation. 264 | 265 | $clock->config (time2Font => "{Liberation Mono} 11"); 266 | 267 | - time2Color ("Gray30") 268 | 269 | Controls the color of the alternate time line of the analog clock. 270 | 271 | $clock->config (time2Color => "#00ff00"); 272 | 273 | - time2Format ("HH:MM:SS") 274 | 275 | Defines the format of the alternate time line of the analog clock. By 276 | default it will display the time in a 24-hour notation. 277 | 278 | The supported format is the same as for `timeFormat`. 279 | 280 | - time2TZ ("Europe/Amsterdam") 281 | 282 | Define the time zone for the alternate time in the analog clock. When 283 | undefined, it disables the display of an alternate time. Empty defaults to 284 | "UTC". 285 | 286 | $clock->config (time2TZ => undef); 287 | $clock->config (time2TZ => "UTC"); 288 | 289 | - dateFont ("fixed 6") 290 | 291 | Controls the font to be used for the bottom line in the digital clock. Will 292 | accept all fonts that are supported in your version of perl/Tk. This includes 293 | both True Type and X11 notation. 294 | 295 | $clock->config (dateFont => "-misc-fixed-*-normal--15-*-c-iso8859-1"); 296 | 297 | - dateColor ("Blue4") 298 | 299 | Controls the color of the second line (date) of the digital clock. 300 | 301 | $clock->config (dateColor => "Navy"); 302 | 303 | - dateFormat ("dd-mm-yy") 304 | 305 | Defines the format of the second line of the digital clock. By default it 306 | will display the date in three groups of two digits representing the day of 307 | the month, the month, and the last two digits of the year, separated by dashes. 308 | 309 | $clock->config (dateFormat => "ww dd-mm"); 310 | 311 | The supported format is the same as for `timeFormat`. 312 | 313 | - infoFont ("fixed 6") 314 | 315 | Controls the font to be used for the info label in the analog clock. Will 316 | accept all fonts that are supported in your version of perl/Tk. This includes 317 | both True Type and X11 notation. 318 | 319 | $clock->config (infoFont => "{DejaVu Sans Mono} 8"); 320 | 321 | - infoColor ("#cfb53b") 322 | 323 | Controls the color of the info label of the analog clock (default is a 324 | shade of Gold). 325 | 326 | $clock->config (infoColor => "Yellow"); 327 | 328 | - infoFormat ("HH:MM:SS") 329 | 330 | Defines the format of the label inside the analog clock. By default will not 331 | be displayed. Just as `timeFormat` and `dateFormat` the content is updated 332 | every second if enabled. 333 | 334 | $clock->config (infoFormat => "BREITLING"); 335 | 336 | The supported format is the same as for `timeFormat`. 337 | 338 | - digiAlign ("center") 339 | 340 | Controls the placement of the text in the digital clock. The only legal values 341 | for `digiAlign` are "left", "center", and "right". 342 | Any other value will be interpreted as the default "center". 343 | 344 | $clock->config (digiAlign => "right"); 345 | 346 | - backDrop ("") 347 | 348 | By default the background of the clock is controlled by the `-background` 349 | attribute to the constructor, which may default to the default background 350 | used in the perl/Tk script. 351 | 352 | The `backDrop` attribute accepts any valid Tk::Photo object, and it will 353 | show (part of) the image as a backdrop of the clock 354 | 355 | use Tk; 356 | use Tk::Clock; 357 | use Tk::Photo; 358 | use Tk::PNG; 359 | 360 | my $mainw = MainWindow->new; 361 | my $backd = $mainw->Photo ( 362 | -file => "image.png", 363 | ); 364 | my $clock = $mainw->Clock ( 365 | -relief => "flat", 366 | )->pack (-expand => 1, -fill => "both"); 367 | $clock->config ( 368 | backDrop => $backd, 369 | ); 370 | MainLoop; 371 | 372 | The `new ()` constructor will also accept options valid for Canvas widgets, 373 | like `-background` and `-relief`. 374 | 375 | # TAGS 376 | 377 | As all of the clock is part of a Canvas, the items cannot be addressed as 378 | Subwidgets. You can however alter presentation afterwards using the tags: 379 | 380 | my $clock = $mw->Clock->pack; 381 | $clock->itemconfigure ("date", -fill => "Red"); 382 | 383 | Currently defined tags are `date`, `hour`, `info`, `min`, `sec`, 384 | `tick`, and `time`. 385 | 386 | # BUGS 387 | 388 | If the system load's too high, the clock might skip some seconds. 389 | 390 | There's no check if either format will fit in the given space. 391 | 392 | # TODO 393 | 394 | \* Full support for multi-line date- and time-formats with auto-resize. 395 | \* Countdown clock API, incl action when done. 396 | \* Better docs for the attributes 397 | 398 | # SEE ALSO 399 | 400 | Tk(3), Tk::Canvas(3), Tk::Widget(3), Tk::Derived(3) 401 | 402 | # AUTHOR 403 | 404 | H.Merijn Brand 405 | 406 | Thanks to Larry Wall for inventing perl. 407 | Thanks to Nick Ing-Simmons for providing perlTk. 408 | Thanks to Achim Bohnet for introducing me to OO (and converting 409 | the basics of my clock.pl to Tk::Clock.pm). 410 | Thanks to Sriram Srinivasan for understanding OO though his Panther book. 411 | Thanks to all CPAN providers for support of different modules to learn from. 412 | Thanks to all who have given me feedback and weird ideas. 413 | 414 | # COPYRIGHT AND LICENSE 415 | 416 | Copyright (C) 1999-2024 H.Merijn Brand 417 | 418 | This library is free software; you can redistribute it and/or modify 419 | it under the same terms as Perl itself. 420 | -------------------------------------------------------------------------------- /doc/Clock.man: -------------------------------------------------------------------------------- 1 | STDIN(1) User Contributed Perl Documentation STDIN(1) 2 | 3 | NAME 4 | Tk::Clock - Clock widget with analog and digital display 5 | 6 | SYNOPSIS 7 | use Tk; 8 | use Tk::Clock; 9 | 10 | $clock = $parent->Clock (?-option => ...?); 11 | 12 | $clock->config ( # These reflect the defaults 13 | timeZone => "", 14 | useLocale => "C", 15 | backDrop => "", 16 | 17 | useAnalog => 1, 18 | handColor => "Green4", 19 | secsColor => "Green2", 20 | tickColor => "Yellow4", 21 | tickFreq => 1, 22 | tickDiff => 0, 23 | useSecHand => 1, 24 | handCenter => 0, 25 | anaScale => 100, 26 | autoScale => 0, 27 | ana24hour => 0, 28 | countDown => 0, 29 | timerValue => 0, 30 | localOffset => 0, 31 | 32 | useInfo => 0, 33 | infoColor => "#cfb53b", 34 | infoFormat => "HH:MM:SS", 35 | infoFont => "fixed 6", 36 | useText => 0, 37 | textColor => "#c4c4c4", 38 | textFormat => "HH:MM:SS", 39 | textFont => "fixed 6", 40 | time2Font => "fixed 6", 41 | time2Color => "Red4", 42 | time2Format => "HH:MM:SS", 43 | time2TZ => "Europe/Amsterdam", 44 | 45 | useDigital => 1, 46 | digiAlign => "center", 47 | timeFont => "fixed 6", 48 | timeColor => "Red4", 49 | timeFormat => "HH:MM:SS", 50 | dateFont => "fixed 6", 51 | dateColor => "Blue4", 52 | dateFormat => "dd-mm-yy", 53 | ); 54 | 55 | DESCRIPTION 56 | This module implements a Canvas-based clock widget for perl-Tk with 57 | lots of options to change the appearance. 58 | 59 | Both analog and digital clocks are implemented. 60 | 61 | METHODS 62 | Clock 63 | This is the constructor. It does accept the standard widget options 64 | plus those described in "config". 65 | 66 | config 67 | Below is a description of the options/attributes currently available. 68 | Their default value is in between parenthesis. 69 | 70 | useAnalog (1) 71 | useInfo (0) 72 | useText (0) 73 | useDigital (1) 74 | Enable the analog clock ("useAnalog") and/or the digital clock 75 | ("useDigital") in the widget. The analog clock will always be 76 | displayed above the digital part 77 | 78 | +----------+ ...... 79 | | .. | \ . \ | . 80 | | . \_ . | |_ Analog clock . Tim2 . 81 | | . . | | . * . 82 | | .. | / . Info . 83 | | 23:59:59 | --- Digital time . Text . 84 | | 31-12-09 | --- Digital date ...... 85 | +----------+ 86 | 87 | The analog clock displays ticks, hour hand, minutes hand and second 88 | hand. The digital part displays two parts, which are configurable. 89 | By default these are time and date. 90 | 91 | The "useInfo" enables a text field between the backdrop of the 92 | analog clock and its items. You can use this field to display 93 | personal data. 94 | 95 | The "useText" is like second line of "useInfo", but with support 96 | for callbacks or variable binding. 97 | 98 | $clock->configure (useText => 1, textFormat => \$foo); 99 | $clock->configure (useText => 1, textFormat => sub { int rand 42 }); 100 | 101 | autoScale (0) 102 | When set to a true value, the widget will try to re-scale itself to 103 | automatically fit the containing widget. 104 | 105 | $clock->config (autoScale => 1); 106 | 107 | anaScale (100) 108 | The analog clock can be enlarged or reduced using anaScale for 109 | which the default of 100% is about 72x72 pixels. 110 | 111 | When using "pack" for your geometry management, be sure to pass 112 | "-expand => 1, -fill => "both"" if you plan to resize with 113 | "anaScale" or enable/disable either analog or digital after the 114 | clock was displayed. 115 | 116 | $clock->config (anaScale => 400); 117 | 118 | ana24hour (0) 119 | The default for the analog clock it the normal 12 hours display, as 120 | most clocks are. This option will show a clock where one round of 121 | the hour-hand will cover a full day of 24 hours, noon is at the 122 | bottom where the 6 will normally display. 123 | 124 | $clock->config (ana24hour => 1); 125 | 126 | useSecHand (1) 127 | This controls weather the seconds-hand is shown. 128 | 129 | $clock->config (useSecHand => 0); 130 | 131 | countDown (0) 132 | When "countDown" is set to a true value, the clock will run 133 | backwards. This is a slightly experimental feature, it will not 134 | count down to a specific point in time, but will simply reverse the 135 | rotation, making the analog clock run counterclockwise. 136 | 137 | timerValue (0) 138 | This represents a countdown timer. 139 | 140 | When setting "timerValue" to a number of seconds, the format values 141 | "Hc", "Mc", and "Sc" will represent the hour, minute and second of 142 | the this value. When the time reaches 0, all countdown values are 143 | reset to 0. 144 | 145 | localOffset (0) 146 | The value of this attribute represents the local offset for this 147 | clock in seconds. Negative is back in time, positive is in the 148 | future. 149 | 150 | # Wind back clock 4 days, 5 hours, 6 minutes and 7 seconds 151 | $clock->config (localOffset => -363967); 152 | 153 | handColor ("Green4") 154 | secsColor ("Green2") 155 | Set the color of the hands of the analog clock. "handColor" 156 | controls the color for both the hour-hand and the minute-hand. 157 | "secsColor" controls the color for the seconds-hand. 158 | 159 | $clock->config ( 160 | handColor => "#7F0000", 161 | secsColor => "OrangeRed", 162 | ); 163 | 164 | handCenter (0) 165 | If set to a true value, will display a circular extension in the 166 | center of the analog clock that extends the hands as if they have a 167 | wider area at their turning point, like many station-type clocks 168 | (at least in the Netherlands) have. 169 | 170 | $clock->config (handCenter => 1); 171 | 172 | tickColor ("Yellow4") 173 | Controls the color of the ticks in the analog clock. 174 | 175 | $clock->config (tickColor => "White"); 176 | 177 | tickFreq (1) 178 | tickDiff (0) 179 | "tickFreq" controls how many ticks are shown in the analog clock. 180 | 181 | Meaningful values for "tickFreq" are 1, 5 and 15 showing all ticks, 182 | tick every 5 minutes or the four main ticks only, though any 183 | positive integer will do (put a tick on any "tickFreq" minute). 184 | 185 | When setting tickDiff to a true value, the major ticks will use a 186 | thicker line than the minor ticks. 187 | 188 | $clock->config ( 189 | tickFreq => 5, 190 | tickDiff => 1, 191 | ); 192 | 193 | timeZone ("") 194 | Set the timezone for the widget. The format should be the format 195 | recognized by the system. If unset, the local timezone is used. 196 | 197 | $clock->config (timeZone => "Europe/Amsterdam"); 198 | $clock->config (timeZone => "MET-1METDST"); 199 | 200 | useLocale ("C") 201 | Use this locale for the text shown in month formats "mmm" and 202 | "mmmm" and in day formats "ddd" and "dddd". 203 | 204 | $clock->config (useLocale => $ENV{LC_TIME} // $ENV{LC_ALL} 205 | // $ENV{LANG} // "nl_NL.utf8"); 206 | 207 | See for a table of 208 | locales and the Windows equivalents. Windows might not have a UTF8 209 | version available of the required locale. 210 | 211 | timeFont ("fixed 6") 212 | Controls the font to be used for the top line in the digital clock. 213 | Will accept all fonts that are supported in your version of 214 | perl/Tk. This includes both True Type and X11 notation. 215 | 216 | $clock->config (timeFont => "{Liberation Mono} 11"); 217 | 218 | timeColor ("Red4") 219 | Controls the color of the first line (time) of the digital clock. 220 | 221 | $clock->config (timeColor => "#00ff00"); 222 | 223 | timeFormat ("HH:MM:SS") 224 | Defines the format of the first line of the digital clock. By 225 | default it will display the time in a 24-hour notation. 226 | 227 | Legal "timeFormat" characters are "H" and "HH" for 24-hour, "h" and 228 | "hh" for AM/PM hour, "M" and "MM" for minutes, "S" and "SS" for 229 | seconds, "Hc" for countdown/timer hour, "Mc" for countdown/timer 230 | minutes, "Sc" for countdown/timer seconds, "A" for AM/PM indicator, 231 | "d" and "dd" for day-of-the month, "ddd" and "dddd" for short and 232 | long weekday, "m", "mm", "mmm" and "mmmm" for month, "y" and "yy" 233 | for year, "w" and "ww" for week-number and any separators ":", "-", 234 | "/" or "space". 235 | 236 | $clock->config (timeFormat => "hh:MM A"); 237 | 238 | The text shown in the formats "ddd", "dddd", "mmm", and "mmmm" 239 | might be influenced by the setting of "useLocale". The fallback is 240 | locale "C". 241 | 242 | time2Font ("fixed 6") 243 | Controls the font to be used for the alternate time in the analog 244 | clock. Will accept all fonts that are supported in your version of 245 | perl/Tk. This includes both True Type and X11 notation. 246 | 247 | $clock->config (time2Font => "{Liberation Mono} 11"); 248 | 249 | time2Color ("Gray30") 250 | Controls the color of the alternate time line of the analog clock. 251 | 252 | $clock->config (time2Color => "#00ff00"); 253 | 254 | time2Format ("HH:MM:SS") 255 | Defines the format of the alternate time line of the analog clock. 256 | By default it will display the time in a 24-hour notation. 257 | 258 | The supported format is the same as for "timeFormat". 259 | 260 | time2TZ ("Europe/Amsterdam") 261 | Define the time zone for the alternate time in the analog clock. 262 | When undefined, it disables the display of an alternate time. Empty 263 | defaults to "UTC". 264 | 265 | $clock->config (time2TZ => undef); 266 | $clock->config (time2TZ => "UTC"); 267 | 268 | dateFont ("fixed 6") 269 | Controls the font to be used for the bottom line in the digital 270 | clock. Will accept all fonts that are supported in your version of 271 | perl/Tk. This includes both True Type and X11 notation. 272 | 273 | $clock->config (dateFont => "-misc-fixed-*-normal--15-*-c-iso8859-1"); 274 | 275 | dateColor ("Blue4") 276 | Controls the color of the second line (date) of the digital clock. 277 | 278 | $clock->config (dateColor => "Navy"); 279 | 280 | dateFormat ("dd-mm-yy") 281 | Defines the format of the second line of the digital clock. By 282 | default it will display the date in three groups of two digits 283 | representing the day of the month, the month, and the last two 284 | digits of the year, separated by dashes. 285 | 286 | $clock->config (dateFormat => "ww dd-mm"); 287 | 288 | The supported format is the same as for "timeFormat". 289 | 290 | infoFont ("fixed 6") 291 | Controls the font to be used for the info label in the analog 292 | clock. Will accept all fonts that are supported in your version of 293 | perl/Tk. This includes both True Type and X11 notation. 294 | 295 | $clock->config (infoFont => "{DejaVu Sans Mono} 8"); 296 | 297 | infoColor ("#cfb53b") 298 | Controls the color of the info label of the analog clock (default 299 | is a shade of Gold). 300 | 301 | $clock->config (infoColor => "Yellow"); 302 | 303 | infoFormat ("HH:MM:SS") 304 | Defines the format of the label inside the analog clock. By default 305 | will not be displayed. Just as "timeFormat" and "dateFormat" the 306 | content is updated every second if enabled. 307 | 308 | $clock->config (infoFormat => "BREITLING"); 309 | 310 | The supported format is the same as for "timeFormat". 311 | 312 | digiAlign ("center") 313 | Controls the placement of the text in the digital clock. The only 314 | legal values for "digiAlign" are "left", "center", and "right". 315 | Any other value will be interpreted as the default "center". 316 | 317 | $clock->config (digiAlign => "right"); 318 | 319 | backDrop ("") 320 | By default the background of the clock is controlled by the 321 | "-background" attribute to the constructor, which may default to 322 | the default background used in the perl/Tk script. 323 | 324 | The "backDrop" attribute accepts any valid Tk::Photo object, and it 325 | will show (part of) the image as a backdrop of the clock 326 | 327 | use Tk; 328 | use Tk::Clock; 329 | use Tk::Photo; 330 | use Tk::PNG; 331 | 332 | my $mainw = MainWindow->new; 333 | my $backd = $mainw->Photo ( 334 | -file => "image.png", 335 | ); 336 | my $clock = $mainw->Clock ( 337 | -relief => "flat", 338 | )->pack (-expand => 1, -fill => "both"); 339 | $clock->config ( 340 | backDrop => $backd, 341 | ); 342 | MainLoop; 343 | 344 | The "new ()" constructor will also accept options valid for Canvas 345 | widgets, like "-background" and "-relief". 346 | 347 | TAGS 348 | As all of the clock is part of a Canvas, the items cannot be addressed 349 | as Subwidgets. You can however alter presentation afterwards using the 350 | tags: 351 | 352 | my $clock = $mw->Clock->pack; 353 | $clock->itemconfigure ("date", -fill => "Red"); 354 | 355 | Currently defined tags are "date", "hour", "info", "min", "sec", 356 | "tick", and "time". 357 | 358 | BUGS 359 | If the system load's too high, the clock might skip some seconds. 360 | 361 | There's no check if either format will fit in the given space. 362 | 363 | TODO 364 | * Full support for multi-line date- and time-formats with auto-resize. 365 | * Countdown clock API, incl action when done. * Better docs for the 366 | attributes 367 | 368 | SEE ALSO 369 | Tk(3), Tk::Canvas(3), Tk::Widget(3), Tk::Derived(3) 370 | 371 | AUTHOR 372 | H.Merijn Brand 373 | 374 | Thanks to Larry Wall for inventing perl. Thanks to Nick Ing-Simmons 375 | for providing perlTk. Thanks to Achim Bohnet for introducing me to OO 376 | (and converting 377 | the basics of my clock.pl to Tk::Clock.pm). Thanks to Sriram 378 | Srinivasan for understanding OO though his Panther book. Thanks to all 379 | CPAN providers for support of different modules to learn from. Thanks 380 | to all who have given me feedback and weird ideas. 381 | 382 | COPYRIGHT AND LICENSE 383 | Copyright (C) 1999-2024 H.Merijn Brand 384 | 385 | This library is free software; you can redistribute it and/or modify it 386 | under the same terms as Perl itself. 387 | 388 | perl v5.40.0 2024-10-31 STDIN(1) 389 | -------------------------------------------------------------------------------- /doc/Clock.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Tk::Clock - Clock widget with analog and digital display 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 31 | 32 |

NAME

33 | 34 |

Tk::Clock - Clock widget with analog and digital display

35 | 36 |

SYNOPSIS

37 | 38 | 
use Tk;
 39 | use Tk::Clock;
 40 | 
 41 | $clock = $parent->Clock (?-option => <value> ...?);
 42 | 
 43 | $clock->config (        # These reflect the defaults
 44 |     timeZone    => "",
 45 |     useLocale   => "C",
 46 |     backDrop    => "",
 47 | 
 48 |     useAnalog   => 1,
 49 |     handColor   => "Green4",
 50 |     secsColor   => "Green2",
 51 |     tickColor   => "Yellow4",
 52 |     tickFreq    => 1,
 53 |     tickDiff    => 0,
 54 |     useSecHand  => 1,
 55 |     handCenter  => 0,
 56 |     anaScale    => 100,
 57 |     autoScale   => 0,
 58 |     ana24hour   => 0,
 59 |     countDown   => 0,
 60 |     timerValue  => 0,
 61 |     localOffset => 0,
 62 | 
 63 |     useInfo     => 0,
 64 |     infoColor   => "#cfb53b",
 65 |     infoFormat  => "HH:MM:SS",
 66 |     infoFont    => "fixed 6",
 67 |     useText     => 0,
 68 |     textColor   => "#c4c4c4",
 69 |     textFormat  => "HH:MM:SS",
 70 |     textFont    => "fixed 6",
 71 |     time2Font   => "fixed 6",
 72 |     time2Color  => "Red4",
 73 |     time2Format => "HH:MM:SS",
 74 |     time2TZ     => "Europe/Amsterdam",
 75 | 
 76 |     useDigital  => 1,
 77 |     digiAlign   => "center",
 78 |     timeFont    => "fixed 6",
 79 |     timeColor   => "Red4",
 80 |     timeFormat  => "HH:MM:SS",
 81 |     dateFont    => "fixed 6",
 82 |     dateColor   => "Blue4",
 83 |     dateFormat  => "dd-mm-yy",
 84 |     );
85 | 86 |

DESCRIPTION

87 | 88 |

This module implements a Canvas-based clock widget for perl-Tk with lots of options to change the appearance.

89 | 90 |

Both analog and digital clocks are implemented.

91 | 92 |

METHODS

93 | 94 |

Clock

95 | 96 |

This is the constructor. It does accept the standard widget options plus those described in "config".

97 | 98 |

config

99 | 100 |

Below is a description of the options/attributes currently available. Their default value is in between parenthesis.

101 | 102 |
103 | 104 |
useAnalog (1)
105 |
106 | 107 |
108 |
useInfo (0)
109 |
110 | 111 |
112 |
useText (0)
113 |
114 | 115 |
116 |
useDigital (1)
117 |
118 | 119 |

Enable the analog clock (useAnalog) and/or the digital clock (useDigital) in the widget. The analog clock will always be displayed above the digital part

120 | 121 | 
+----------+                                   ......
122 | |    ..    |  \                              . \ |    .
123 | |  . \_ .  |   |_ Analog clock              .   Tim2   .
124 | |  .    .  |   |                            .    *     .
125 | |    ..    |  /                             .   Info   .
126 | | 23:59:59 |  --- Digital time               .  Text  .
127 | | 31-12-09 |  --- Digital date                 ......
128 | +----------+
129 | 130 |

The analog clock displays ticks, hour hand, minutes hand and second hand. The digital part displays two parts, which are configurable. By default these are time and date.

131 | 132 |

The useInfo enables a text field between the backdrop of the analog clock and its items. You can use this field to display personal data.

133 | 134 |

The useText is like second line of useInfo, but with support for callbacks or variable binding.

135 | 136 | 
$clock->configure (useText => 1, textFormat => \$foo);
137 | $clock->configure (useText => 1, textFormat => sub { int rand 42 });
138 | 139 |
140 |
autoScale (0)
141 |
142 | 143 |

When set to a true value, the widget will try to re-scale itself to automatically fit the containing widget.

144 | 145 | 
$clock->config (autoScale => 1);
146 | 147 |
148 |
anaScale (100)
149 |
150 | 151 |

The analog clock can be enlarged or reduced using anaScale for which the default of 100% is about 72x72 pixels.

152 | 153 |

When using pack for your geometry management, be sure to pass -expand =&gt; 1, -fill =&gt; "both" if you plan to resize with anaScale or enable/disable either analog or digital after the clock was displayed.

154 | 155 | 
$clock->config (anaScale => 400);
156 | 157 |
158 |
ana24hour (0)
159 |
160 | 161 |

The default for the analog clock it the normal 12 hours display, as most clocks are. This option will show a clock where one round of the hour-hand will cover a full day of 24 hours, noon is at the bottom where the 6 will normally display.

162 | 163 | 
$clock->config (ana24hour => 1);
164 | 165 |
166 |
useSecHand (1)
167 |
168 | 169 |

This controls weather the seconds-hand is shown.

170 | 171 | 
$clock->config (useSecHand => 0);
172 | 173 |
174 |
countDown (0)
175 |
176 | 177 |

When countDown is set to a true value, the clock will run backwards. This is a slightly experimental feature, it will not count down to a specific point in time, but will simply reverse the rotation, making the analog clock run counterclockwise.

178 | 179 |
180 |
timerValue (0)
181 |
182 | 183 |

This represents a countdown timer.

184 | 185 |

When setting timerValue to a number of seconds, the format values Hc, Mc, and Sc will represent the hour, minute and second of the this value. When the time reaches 0, all countdown values are reset to 0.

186 | 187 |
188 |
localOffset (0)
189 |
190 | 191 |

The value of this attribute represents the local offset for this clock in seconds. Negative is back in time, positive is in the future.

192 | 193 | 
# Wind back clock 4 days, 5 hours, 6 minutes and 7 seconds
194 | $clock->config (localOffset => -363967);
195 | 196 |
197 |
handColor ("Green4")
198 |
199 | 200 |
201 |
secsColor ("Green2")
202 |
203 | 204 |

Set the color of the hands of the analog clock. handColor controls the color for both the hour-hand and the minute-hand. secsColor controls the color for the seconds-hand.

205 | 206 | 
$clock->config (
207 |     handColor => "#7F0000",
208 |     secsColor => "OrangeRed",
209 |     );
210 | 211 |
212 |
handCenter (0)
213 |
214 | 215 |

If set to a true value, will display a circular extension in the center of the analog clock that extends the hands as if they have a wider area at their turning point, like many station-type clocks (at least in the Netherlands) have.

216 | 217 | 
$clock->config (handCenter => 1);
218 | 219 |
220 |
tickColor ("Yellow4")
221 |
222 | 223 |

Controls the color of the ticks in the analog clock.

224 | 225 | 
$clock->config (tickColor => "White");
226 | 227 |
228 |
tickFreq (1)
229 |
230 | 231 |
232 |
tickDiff (0)
233 |
234 | 235 |

tickFreq controls how many ticks are shown in the analog clock.

236 | 237 |

Meaningful values for tickFreq are 1, 5 and 15 showing all ticks, tick every 5 minutes or the four main ticks only, though any positive integer will do (put a tick on any tickFreq minute).

238 | 239 |

When setting tickDiff to a true value, the major ticks will use a thicker line than the minor ticks.

240 | 241 | 
$clock->config (
242 |     tickFreq => 5,
243 |     tickDiff => 1,
244 |     );
245 | 246 |
247 |
timeZone ("")
248 |
249 | 250 |

Set the timezone for the widget. The format should be the format recognized by the system. If unset, the local timezone is used.

251 | 252 | 
$clock->config (timeZone => "Europe/Amsterdam");
253 | $clock->config (timeZone => "MET-1METDST");
254 | 255 |
256 |
useLocale ("C")
257 |
258 | 259 |

Use this locale for the text shown in month formats mmm and mmmm and in day formats ddd and dddd.

260 | 261 | 
$clock->config (useLocale => $ENV{LC_TIME} // $ENV{LC_ALL}
262 |                           // $ENV{LANG}    // "nl_NL.utf8");
263 | 264 |

See http://docs.moodle.org/dev/Table_of_locales for a table of locales and the Windows equivalents. Windows might not have a UTF8 version available of the required locale.

265 | 266 |
267 |
timeFont ("fixed 6")
268 |
269 | 270 |

Controls the font to be used for the top line in the digital clock. Will accept all fonts that are supported in your version of perl/Tk. This includes both True Type and X11 notation.

271 | 272 | 
$clock->config (timeFont => "{Liberation Mono} 11");
273 | 274 |
275 |
timeColor ("Red4")
276 |
277 | 278 |

Controls the color of the first line (time) of the digital clock.

279 | 280 | 
$clock->config (timeColor => "#00ff00");
281 | 282 |
283 |
timeFormat ("HH:MM:SS")
284 |
285 | 286 |

Defines the format of the first line of the digital clock. By default it will display the time in a 24-hour notation.

287 | 288 |

Legal timeFormat characters are H and HH for 24-hour, h and hh for AM/PM hour, M and MM for minutes, S and SS for seconds, Hc for countdown/timer hour, Mc for countdown/timer minutes, Sc for countdown/timer seconds, A for AM/PM indicator, d and dd for day-of-the month, ddd and dddd for short and long weekday, m, mm, mmm and mmmm for month, y and yy for year, w and ww for week-number and any separators :, -, / or space.

289 | 290 | 
$clock->config (timeFormat => "hh:MM A");
291 | 292 |

The text shown in the formats ddd, dddd, mmm, and mmmm might be influenced by the setting of useLocale. The fallback is locale "C".

293 | 294 |
295 |
time2Font ("fixed 6")
296 |
297 | 298 |

Controls the font to be used for the alternate time in the analog clock. Will accept all fonts that are supported in your version of perl/Tk. This includes both True Type and X11 notation.

299 | 300 | 
$clock->config (time2Font => "{Liberation Mono} 11");
301 | 302 |
303 |
time2Color ("Gray30")
304 |
305 | 306 |

Controls the color of the alternate time line of the analog clock.

307 | 308 | 
$clock->config (time2Color => "#00ff00");
309 | 310 |
311 |
time2Format ("HH:MM:SS")
312 |
313 | 314 |

Defines the format of the alternate time line of the analog clock. By default it will display the time in a 24-hour notation.

315 | 316 |

The supported format is the same as for timeFormat.

317 | 318 |
319 |
time2TZ ("Europe/Amsterdam")
320 |
321 | 322 |

Define the time zone for the alternate time in the analog clock. When undefined, it disables the display of an alternate time. Empty defaults to "UTC".

323 | 324 | 
$clock->config (time2TZ => undef);
325 | $clock->config (time2TZ => "UTC");
326 | 327 |
328 |
dateFont ("fixed 6")
329 |
330 | 331 |

Controls the font to be used for the bottom line in the digital clock. Will accept all fonts that are supported in your version of perl/Tk. This includes both True Type and X11 notation.

332 | 333 | 
$clock->config (dateFont => "-misc-fixed-*-normal--15-*-c-iso8859-1");
334 | 335 |
336 |
dateColor ("Blue4")
337 |
338 | 339 |

Controls the color of the second line (date) of the digital clock.

340 | 341 | 
$clock->config (dateColor => "Navy");
342 | 343 |
344 |
dateFormat ("dd-mm-yy")
345 |
346 | 347 |

Defines the format of the second line of the digital clock. By default it will display the date in three groups of two digits representing the day of the month, the month, and the last two digits of the year, separated by dashes.

348 | 349 | 
$clock->config (dateFormat => "ww dd-mm");
350 | 351 |

The supported format is the same as for timeFormat.

352 | 353 |
354 |
infoFont ("fixed 6")
355 |
356 | 357 |

Controls the font to be used for the info label in the analog clock. Will accept all fonts that are supported in your version of perl/Tk. This includes both True Type and X11 notation.

358 | 359 | 
$clock->config (infoFont => "{DejaVu Sans Mono} 8");
360 | 361 |
362 |
infoColor ("#cfb53b")
363 |
364 | 365 |

Controls the color of the info label of the analog clock (default is a shade of Gold).

366 | 367 | 
$clock->config (infoColor => "Yellow");
368 | 369 |
370 |
infoFormat ("HH:MM:SS")
371 |
372 | 373 |

Defines the format of the label inside the analog clock. By default will not be displayed. Just as timeFormat and dateFormat the content is updated every second if enabled.

374 | 375 | 
$clock->config (infoFormat => "BREITLING");
376 | 377 |

The supported format is the same as for timeFormat.

378 | 379 |
380 |
digiAlign ("center")
381 |
382 | 383 |

Controls the placement of the text in the digital clock. The only legal values for digiAlign are "left", "center", and "right". Any other value will be interpreted as the default "center".

384 | 385 | 
$clock->config (digiAlign => "right");
386 | 387 |
388 |
backDrop ("")
389 |
390 | 391 |

By default the background of the clock is controlled by the -background attribute to the constructor, which may default to the default background used in the perl/Tk script.

392 | 393 |

The backDrop attribute accepts any valid Tk::Photo object, and it will show (part of) the image as a backdrop of the clock

394 | 395 | 
use Tk;
396 | use Tk::Clock;
397 | use Tk::Photo;
398 | use Tk::PNG;
399 | 
400 | my $mainw = MainWindow->new;
401 | my $backd = $mainw->Photo (
402 |     -file    => "image.png",
403 |     );
404 | my $clock = $mainw->Clock (
405 |     -relief  => "flat",
406 |     )->pack (-expand => 1, -fill => "both");
407 | $clock->config (
408 |     backDrop => $backd,
409 |     );
410 | MainLoop;
411 | 412 |
413 |
414 | 415 |

The new () constructor will also accept options valid for Canvas widgets, like -background and -relief.

416 | 417 |

TAGS

418 | 419 |

As all of the clock is part of a Canvas, the items cannot be addressed as Subwidgets. You can however alter presentation afterwards using the tags:

420 | 421 | 
my $clock = $mw->Clock->pack;
422 | $clock->itemconfigure ("date", -fill => "Red");
423 | 424 |

Currently defined tags are date, hour, info, min, sec, tick, and time.

425 | 426 |

BUGS

427 | 428 |

If the system load's too high, the clock might skip some seconds.

429 | 430 |

There's no check if either format will fit in the given space.

431 | 432 |

TODO

433 | 434 |

* Full support for multi-line date- and time-formats with auto-resize. * Countdown clock API, incl action when done. * Better docs for the attributes

435 | 436 |

SEE ALSO

437 | 438 |

Tk(3), Tk::Canvas(3), Tk::Widget(3), Tk::Derived(3)

439 | 440 |

AUTHOR

441 | 442 |

H.Merijn Brand <h.m.brand@xs4all.nl>

443 | 444 |

Thanks to Larry Wall for inventing perl. Thanks to Nick Ing-Simmons for providing perlTk. Thanks to Achim Bohnet for introducing me to OO (and converting the basics of my clock.pl to Tk::Clock.pm). Thanks to Sriram Srinivasan for understanding OO though his Panther book. Thanks to all CPAN providers for support of different modules to learn from. Thanks to all who have given me feedback and weird ideas.

445 | 446 |

COPYRIGHT AND LICENSE

447 | 448 |

Copyright (C) 1999-2024 H.Merijn Brand

449 | 450 |

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

451 | 452 | 453 | 454 | 455 | 456 | 457 | 458 | -------------------------------------------------------------------------------- /doc/Clock.3: -------------------------------------------------------------------------------- 1 | .\" -*- mode: troff; coding: utf-8 -*- 2 | .\" Automatically generated by Pod::Man v6.0.2 (Pod::Simple 3.45) 3 | .\" 4 | .\" Standard preamble: 5 | .\" ======================================================================== 6 | .de Sp \" Vertical space (when we can't use .PP) 7 | .if t .sp .5v 8 | .if n .sp 9 | .. 10 | .de Vb \" Begin verbatim text 11 | .ft CW 12 | .nf 13 | .ne \\$1 14 | .. 15 | .de Ve \" End verbatim text 16 | .ft R 17 | .fi 18 | .. 19 | .\" \*(C` and \*(C' are quotes in nroff, nothing in troff, for use with C<>. 20 | .ie n \{\ 21 | . ds C` "" 22 | . ds C' "" 23 | 'br\} 24 | .el\{\ 25 | . ds C` 26 | . ds C' 27 | 'br\} 28 | .\" 29 | .\" Escape single quotes in literal strings from groff's Unicode transform. 30 | .ie \n(.g .ds Aq \(aq 31 | .el .ds Aq ' 32 | .\" 33 | .\" If the F register is >0, we'll generate index entries on stderr for 34 | .\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index 35 | .\" entries marked with X<> in POD. Of course, you'll have to process the 36 | .\" output yourself in some meaningful fashion. 37 | .\" 38 | .\" Avoid warning from groff about undefined register 'F'. 39 | .de IX 40 | .. 41 | .nr rF 0 42 | .if \n(.g .if rF .nr rF 1 43 | .if (\n(rF:(\n(.g==0)) \{\ 44 | . if \nF \{\ 45 | . de IX 46 | . tm Index:\\$1\t\\n%\t"\\$2" 47 | .. 48 | . if !\nF==2 \{\ 49 | . nr % 0 50 | . nr F 2 51 | . \} 52 | . \} 53 | .\} 54 | .rr rF 55 | .\" 56 | .\" Required to disable full justification in groff 1.23.0. 57 | .if n .ds AD l 58 | .\" ======================================================================== 59 | .\" 60 | .IX Title "STDIN 1" 61 | .TH STDIN 1 2024-10-31 "perl v5.40.0" "User Contributed Perl Documentation" 62 | .\" For nroff, turn off justification. Always turn off hyphenation; it makes 63 | .\" way too many mistakes in technical documents. 64 | .if n .ad l 65 | .nh 66 | .SH NAME 67 | Tk::Clock \- Clock widget with analog and digital display 68 | .SH SYNOPSIS 69 | .IX Header "SYNOPSIS" 70 | .Vb 2 71 | \& use Tk; 72 | \& use Tk::Clock; 73 | \& 74 | \& $clock = $parent\->Clock (?\-option => ...?); 75 | \& 76 | \& $clock\->config ( # These reflect the defaults 77 | \& timeZone => "", 78 | \& useLocale => "C", 79 | \& backDrop => "", 80 | \& 81 | \& useAnalog => 1, 82 | \& handColor => "Green4", 83 | \& secsColor => "Green2", 84 | \& tickColor => "Yellow4", 85 | \& tickFreq => 1, 86 | \& tickDiff => 0, 87 | \& useSecHand => 1, 88 | \& handCenter => 0, 89 | \& anaScale => 100, 90 | \& autoScale => 0, 91 | \& ana24hour => 0, 92 | \& countDown => 0, 93 | \& timerValue => 0, 94 | \& localOffset => 0, 95 | \& 96 | \& useInfo => 0, 97 | \& infoColor => "#cfb53b", 98 | \& infoFormat => "HH:MM:SS", 99 | \& infoFont => "fixed 6", 100 | \& useText => 0, 101 | \& textColor => "#c4c4c4", 102 | \& textFormat => "HH:MM:SS", 103 | \& textFont => "fixed 6", 104 | \& time2Font => "fixed 6", 105 | \& time2Color => "Red4", 106 | \& time2Format => "HH:MM:SS", 107 | \& time2TZ => "Europe/Amsterdam", 108 | \& 109 | \& useDigital => 1, 110 | \& digiAlign => "center", 111 | \& timeFont => "fixed 6", 112 | \& timeColor => "Red4", 113 | \& timeFormat => "HH:MM:SS", 114 | \& dateFont => "fixed 6", 115 | \& dateColor => "Blue4", 116 | \& dateFormat => "dd\-mm\-yy", 117 | \& ); 118 | .Ve 119 | .SH DESCRIPTION 120 | .IX Header "DESCRIPTION" 121 | This module implements a Canvas\-based clock widget for perl\-Tk with lots 122 | of options to change the appearance. 123 | .PP 124 | Both analog and digital clocks are implemented. 125 | .SH METHODS 126 | .IX Header "METHODS" 127 | .SS Clock 128 | .IX Subsection "Clock" 129 | This is the constructor. It does accept the standard widget options plus those 130 | described in "config". 131 | .SS config 132 | .IX Subsection "config" 133 | Below is a description of the options/attributes currently available. Their 134 | default value is in between parenthesis. 135 | .IP "useAnalog (1)" 4 136 | .IX Item "useAnalog (1)" 137 | .PD 0 138 | .IP "useInfo (0)" 4 139 | .IX Item "useInfo (0)" 140 | .IP "useText (0)" 4 141 | .IX Item "useText (0)" 142 | .IP "useDigital (1)" 4 143 | .IX Item "useDigital (1)" 144 | .PD 145 | Enable the analog clock (\f(CW\*(C`useAnalog\*(C'\fR) and/or the digital clock (\f(CW\*(C`useDigital\*(C'\fR) 146 | in the widget. The analog clock will always be displayed above the digital part 147 | .Sp 148 | .Vb 8 149 | \& +\-\-\-\-\-\-\-\-\-\-+ ...... 150 | \& | .. | \e . \e | . 151 | \& | . \e_ . | |_ Analog clock . Tim2 . 152 | \& | . . | | . * . 153 | \& | .. | / . Info . 154 | \& | 23:59:59 | \-\-\- Digital time . Text . 155 | \& | 31\-12\-09 | \-\-\- Digital date ...... 156 | \& +\-\-\-\-\-\-\-\-\-\-+ 157 | .Ve 158 | .Sp 159 | The analog clock displays ticks, hour hand, minutes hand and second hand. 160 | The digital part displays two parts, which are configurable. By default 161 | these are time and date. 162 | .Sp 163 | The \f(CW\*(C`useInfo\*(C'\fR enables a text field between the backdrop of the analog 164 | clock and its items. You can use this field to display personal data. 165 | .Sp 166 | The \f(CW\*(C`useText\*(C'\fR is like second line of \f(CW\*(C`useInfo\*(C'\fR, but with support for 167 | callbacks or variable binding. 168 | .Sp 169 | .Vb 2 170 | \& $clock\->configure (useText => 1, textFormat => \e$foo); 171 | \& $clock\->configure (useText => 1, textFormat => sub { int rand 42 }); 172 | .Ve 173 | .IP "autoScale (0)" 4 174 | .IX Item "autoScale (0)" 175 | When set to a true value, the widget will try to re\-scale itself to 176 | automatically fit the containing widget. 177 | .Sp 178 | .Vb 1 179 | \& $clock\->config (autoScale => 1); 180 | .Ve 181 | .IP "anaScale (100)" 4 182 | .IX Item "anaScale (100)" 183 | The analog clock can be enlarged or reduced using anaScale for which 184 | the default of 100% is about 72x72 pixels. 185 | .Sp 186 | When using \f(CW\*(C`pack\*(C'\fR for your geometry management, be sure to pass 187 | \&\f(CW\*(C`\-expand => 1, \-fill => "both"\*(C'\fR if you plan to resize with 188 | \&\f(CW\*(C`anaScale\*(C'\fR or enable/disable either analog or digital after the 189 | clock was displayed. 190 | .Sp 191 | .Vb 1 192 | \& $clock\->config (anaScale => 400); 193 | .Ve 194 | .IP "ana24hour (0)" 4 195 | .IX Item "ana24hour (0)" 196 | The default for the analog clock it the normal 12 hours display, as 197 | most clocks are. This option will show a clock where one round of the 198 | hour\-hand will cover a full day of 24 hours, noon is at the bottom 199 | where the 6 will normally display. 200 | .Sp 201 | .Vb 1 202 | \& $clock\->config (ana24hour => 1); 203 | .Ve 204 | .IP "useSecHand (1)" 4 205 | .IX Item "useSecHand (1)" 206 | This controls weather the seconds\-hand is shown. 207 | .Sp 208 | .Vb 1 209 | \& $clock\->config (useSecHand => 0); 210 | .Ve 211 | .IP "countDown (0)" 4 212 | .IX Item "countDown (0)" 213 | When \f(CW\*(C`countDown\*(C'\fR is set to a true value, the clock will run backwards. 214 | This is a slightly experimental feature, it will not count down to a 215 | specific point in time, but will simply reverse the rotation, making 216 | the analog clock run counterclockwise. 217 | .IP "timerValue (0)" 4 218 | .IX Item "timerValue (0)" 219 | This represents a countdown timer. 220 | .Sp 221 | When setting \f(CW\*(C`timerValue\*(C'\fR to a number of seconds, the format values 222 | \&\f(CW\*(C`Hc\*(C'\fR, \f(CW\*(C`Mc\*(C'\fR, and \f(CW\*(C`Sc\*(C'\fR will represent the hour, minute and second of 223 | the this value. When the time reaches 0, all countdown values are 224 | reset to 0. 225 | .IP "localOffset (0)" 4 226 | .IX Item "localOffset (0)" 227 | The value of this attribute represents the local offset for this clock 228 | in seconds. Negative is back in time, positive is in the future. 229 | .Sp 230 | .Vb 2 231 | \& # Wind back clock 4 days, 5 hours, 6 minutes and 7 seconds 232 | \& $clock\->config (localOffset => \-363967); 233 | .Ve 234 | .IP "handColor (""Green4"")" 4 235 | .IX Item "handColor (""Green4"")" 236 | .PD 0 237 | .IP "secsColor (""Green2"")" 4 238 | .IX Item "secsColor (""Green2"")" 239 | .PD 240 | Set the color of the hands of the analog clock. \f(CW\*(C`handColor\*(C'\fR controls 241 | the color for both the hour\-hand and the minute\-hand. \f(CW\*(C`secsColor\*(C'\fR 242 | controls the color for the seconds\-hand. 243 | .Sp 244 | .Vb 4 245 | \& $clock\->config ( 246 | \& handColor => "#7F0000", 247 | \& secsColor => "OrangeRed", 248 | \& ); 249 | .Ve 250 | .IP "handCenter (0)" 4 251 | .IX Item "handCenter (0)" 252 | If set to a true value, will display a circular extension in the center 253 | of the analog clock that extends the hands as if they have a wider area 254 | at their turning point, like many station\-type clocks (at least in the 255 | Netherlands) have. 256 | .Sp 257 | .Vb 1 258 | \& $clock\->config (handCenter => 1); 259 | .Ve 260 | .IP "tickColor (""Yellow4"")" 4 261 | .IX Item "tickColor (""Yellow4"")" 262 | Controls the color of the ticks in the analog clock. 263 | .Sp 264 | .Vb 1 265 | \& $clock\->config (tickColor => "White"); 266 | .Ve 267 | .IP "tickFreq (1)" 4 268 | .IX Item "tickFreq (1)" 269 | .PD 0 270 | .IP "tickDiff (0)" 4 271 | .IX Item "tickDiff (0)" 272 | .PD 273 | \&\f(CW\*(C`tickFreq\*(C'\fR controls how many ticks are shown in the analog clock. 274 | .Sp 275 | Meaningful values for \f(CW\*(C`tickFreq\*(C'\fR are 1, 5 and 15 showing all ticks, tick 276 | every 5 minutes or the four main ticks only, though any positive integer 277 | will do (put a tick on any \f(CW\*(C`tickFreq\*(C'\fR minute). 278 | .Sp 279 | When setting tickDiff to a true value, the major ticks will use a thicker 280 | line than the minor ticks. 281 | .Sp 282 | .Vb 4 283 | \& $clock\->config ( 284 | \& tickFreq => 5, 285 | \& tickDiff => 1, 286 | \& ); 287 | .Ve 288 | .IP "timeZone ("""")" 4 289 | .IX Item "timeZone ("""")" 290 | Set the timezone for the widget. The format should be the format recognized 291 | by the system. If unset, the local timezone is used. 292 | .Sp 293 | .Vb 2 294 | \& $clock\->config (timeZone => "Europe/Amsterdam"); 295 | \& $clock\->config (timeZone => "MET\-1METDST"); 296 | .Ve 297 | .IP "useLocale (""C"")" 4 298 | .IX Item "useLocale (""C"")" 299 | Use this locale for the text shown in month formats \f(CW\*(C`mmm\*(C'\fR and \f(CW\*(C`mmmm\*(C'\fR and in 300 | day formats \f(CW\*(C`ddd\*(C'\fR and \f(CW\*(C`dddd\*(C'\fR. 301 | .Sp 302 | .Vb 2 303 | \& $clock\->config (useLocale => $ENV{LC_TIME} // $ENV{LC_ALL} 304 | \& // $ENV{LANG} // "nl_NL.utf8"); 305 | .Ve 306 | .Sp 307 | See for a table of locales 308 | and the Windows equivalents. Windows might not have a UTF8 version available 309 | of the required locale. 310 | .IP "timeFont (""fixed 6"")" 4 311 | .IX Item "timeFont (""fixed 6"")" 312 | Controls the font to be used for the top line in the digital clock. Will 313 | accept all fonts that are supported in your version of perl/Tk. This includes 314 | both True Type and X11 notation. 315 | .Sp 316 | .Vb 1 317 | \& $clock\->config (timeFont => "{Liberation Mono} 11"); 318 | .Ve 319 | .IP "timeColor (""Red4"")" 4 320 | .IX Item "timeColor (""Red4"")" 321 | Controls the color of the first line (time) of the digital clock. 322 | .Sp 323 | .Vb 1 324 | \& $clock\->config (timeColor => "#00ff00"); 325 | .Ve 326 | .IP "timeFormat (""HH:MM:SS"")" 4 327 | .IX Item "timeFormat (""HH:MM:SS"")" 328 | Defines the format of the first line of the digital clock. By default it 329 | will display the time in a 24\-hour notation. 330 | .Sp 331 | Legal \f(CW\*(C`timeFormat\*(C'\fR characters are \f(CW\*(C`H\*(C'\fR and \f(CW\*(C`HH\*(C'\fR for 24\-hour, \f(CW\*(C`h\*(C'\fR and 332 | \&\f(CW\*(C`hh\*(C'\fR for AM/PM hour, \f(CW\*(C`M\*(C'\fR and \f(CW\*(C`MM\*(C'\fR for minutes, \f(CW\*(C`S\*(C'\fR and \f(CW\*(C`SS\*(C'\fR for 333 | seconds, \f(CW\*(C`Hc\*(C'\fR for countdown/timer hour, \f(CW\*(C`Mc\*(C'\fR for countdown/timer 334 | minutes, \f(CW\*(C`Sc\*(C'\fR for countdown/timer seconds, \f(CW\*(C`A\*(C'\fR for AM/PM indicator, 335 | \&\f(CW\*(C`d\*(C'\fR and \f(CW\*(C`dd\*(C'\fR for day\-of\-the month, \f(CW\*(C`ddd\*(C'\fR and \f(CW\*(C`dddd\*(C'\fR for short and 336 | long weekday, \f(CW\*(C`m\*(C'\fR, \f(CW\*(C`mm\*(C'\fR, \f(CW\*(C`mmm\*(C'\fR and \f(CW\*(C`mmmm\*(C'\fR for month, \f(CW\*(C`y\*(C'\fR and \f(CW\*(C`yy\*(C'\fR 337 | for year, \f(CW\*(C`w\*(C'\fR and \f(CW\*(C`ww\*(C'\fR for week\-number and any separators \f(CW\*(C`:\*(C'\fR, \f(CW\*(C`\-\*(C'\fR, 338 | \&\f(CW\*(C`/\*(C'\fR or \f(CW\*(C`space\*(C'\fR. 339 | .Sp 340 | .Vb 1 341 | \& $clock\->config (timeFormat => "hh:MM A"); 342 | .Ve 343 | .Sp 344 | The text shown in the formats \f(CW\*(C`ddd\*(C'\fR, \f(CW\*(C`dddd\*(C'\fR, \f(CW\*(C`mmm\*(C'\fR, and \f(CW\*(C`mmmm\*(C'\fR might be 345 | influenced by the setting of \f(CW\*(C`useLocale\*(C'\fR. The fallback is locale "C". 346 | .IP "time2Font (""fixed 6"")" 4 347 | .IX Item "time2Font (""fixed 6"")" 348 | Controls the font to be used for the alternate time in the analog clock. Will 349 | accept all fonts that are supported in your version of perl/Tk. This includes 350 | both True Type and X11 notation. 351 | .Sp 352 | .Vb 1 353 | \& $clock\->config (time2Font => "{Liberation Mono} 11"); 354 | .Ve 355 | .IP "time2Color (""Gray30"")" 4 356 | .IX Item "time2Color (""Gray30"")" 357 | Controls the color of the alternate time line of the analog clock. 358 | .Sp 359 | .Vb 1 360 | \& $clock\->config (time2Color => "#00ff00"); 361 | .Ve 362 | .IP "time2Format (""HH:MM:SS"")" 4 363 | .IX Item "time2Format (""HH:MM:SS"")" 364 | Defines the format of the alternate time line of the analog clock. By 365 | default it will display the time in a 24\-hour notation. 366 | .Sp 367 | The supported format is the same as for \f(CW\*(C`timeFormat\*(C'\fR. 368 | .IP "time2TZ (""Europe/Amsterdam"")" 4 369 | .IX Item "time2TZ (""Europe/Amsterdam"")" 370 | Define the time zone for the alternate time in the analog clock. When 371 | undefined, it disables the display of an alternate time. Empty defaults to 372 | "UTC". 373 | .Sp 374 | .Vb 2 375 | \& $clock\->config (time2TZ => undef); 376 | \& $clock\->config (time2TZ => "UTC"); 377 | .Ve 378 | .IP "dateFont (""fixed 6"")" 4 379 | .IX Item "dateFont (""fixed 6"")" 380 | Controls the font to be used for the bottom line in the digital clock. Will 381 | accept all fonts that are supported in your version of perl/Tk. This includes 382 | both True Type and X11 notation. 383 | .Sp 384 | .Vb 1 385 | \& $clock\->config (dateFont => "\-misc\-fixed\-*\-normal\-\-15\-*\-c\-iso8859\-1"); 386 | .Ve 387 | .IP "dateColor (""Blue4"")" 4 388 | .IX Item "dateColor (""Blue4"")" 389 | Controls the color of the second line (date) of the digital clock. 390 | .Sp 391 | .Vb 1 392 | \& $clock\->config (dateColor => "Navy"); 393 | .Ve 394 | .IP "dateFormat (""dd\-mm\-yy"")" 4 395 | .IX Item "dateFormat (""dd-mm-yy"")" 396 | Defines the format of the second line of the digital clock. By default it 397 | will display the date in three groups of two digits representing the day of 398 | the month, the month, and the last two digits of the year, separated by dashes. 399 | .Sp 400 | .Vb 1 401 | \& $clock\->config (dateFormat => "ww dd\-mm"); 402 | .Ve 403 | .Sp 404 | The supported format is the same as for \f(CW\*(C`timeFormat\*(C'\fR. 405 | .IP "infoFont (""fixed 6"")" 4 406 | .IX Item "infoFont (""fixed 6"")" 407 | Controls the font to be used for the info label in the analog clock. Will 408 | accept all fonts that are supported in your version of perl/Tk. This includes 409 | both True Type and X11 notation. 410 | .Sp 411 | .Vb 1 412 | \& $clock\->config (infoFont => "{DejaVu Sans Mono} 8"); 413 | .Ve 414 | .IP "infoColor (""#cfb53b"")" 4 415 | .IX Item "infoColor (""#cfb53b"")" 416 | Controls the color of the info label of the analog clock (default is a 417 | shade of Gold). 418 | .Sp 419 | .Vb 1 420 | \& $clock\->config (infoColor => "Yellow"); 421 | .Ve 422 | .IP "infoFormat (""HH:MM:SS"")" 4 423 | .IX Item "infoFormat (""HH:MM:SS"")" 424 | Defines the format of the label inside the analog clock. By default will not 425 | be displayed. Just as \f(CW\*(C`timeFormat\*(C'\fR and \f(CW\*(C`dateFormat\*(C'\fR the content is updated 426 | every second if enabled. 427 | .Sp 428 | .Vb 1 429 | \& $clock\->config (infoFormat => "BREITLING"); 430 | .Ve 431 | .Sp 432 | The supported format is the same as for \f(CW\*(C`timeFormat\*(C'\fR. 433 | .IP "digiAlign (""center"")" 4 434 | .IX Item "digiAlign (""center"")" 435 | Controls the placement of the text in the digital clock. The only legal values 436 | for \f(CW\*(C`digiAlign\*(C'\fR are "left", "center", and "right". 437 | Any other value will be interpreted as the default "center". 438 | .Sp 439 | .Vb 1 440 | \& $clock\->config (digiAlign => "right"); 441 | .Ve 442 | .IP "backDrop ("""")" 4 443 | .IX Item "backDrop ("""")" 444 | By default the background of the clock is controlled by the \f(CW\*(C`\-background\*(C'\fR 445 | attribute to the constructor, which may default to the default background 446 | used in the perl/Tk script. 447 | .Sp 448 | The \f(CW\*(C`backDrop\*(C'\fR attribute accepts any valid Tk::Photo object, and it will 449 | show (part of) the image as a backdrop of the clock 450 | .Sp 451 | .Vb 4 452 | \& use Tk; 453 | \& use Tk::Clock; 454 | \& use Tk::Photo; 455 | \& use Tk::PNG; 456 | \& 457 | \& my $mainw = MainWindow\->new; 458 | \& my $backd = $mainw\->Photo ( 459 | \& \-file => "image.png", 460 | \& ); 461 | \& my $clock = $mainw\->Clock ( 462 | \& \-relief => "flat", 463 | \& )\->pack (\-expand => 1, \-fill => "both"); 464 | \& $clock\->config ( 465 | \& backDrop => $backd, 466 | \& ); 467 | \& MainLoop; 468 | .Ve 469 | .PP 470 | The \f(CW\*(C`new ()\*(C'\fR constructor will also accept options valid for Canvas widgets, 471 | like \f(CW\*(C`\-background\*(C'\fR and \f(CW\*(C`\-relief\*(C'\fR. 472 | .SH TAGS 473 | .IX Header "TAGS" 474 | As all of the clock is part of a Canvas, the items cannot be addressed as 475 | Subwidgets. You can however alter presentation afterwards using the tags: 476 | .PP 477 | .Vb 2 478 | \& my $clock = $mw\->Clock\->pack; 479 | \& $clock\->itemconfigure ("date", \-fill => "Red"); 480 | .Ve 481 | .PP 482 | Currently defined tags are \f(CW\*(C`date\*(C'\fR, \f(CW\*(C`hour\*(C'\fR, \f(CW\*(C`info\*(C'\fR, \f(CW\*(C`min\*(C'\fR, \f(CW\*(C`sec\*(C'\fR, 483 | \&\f(CW\*(C`tick\*(C'\fR, and \f(CW\*(C`time\*(C'\fR. 484 | .SH BUGS 485 | .IX Header "BUGS" 486 | If the system load\*(Aqs too high, the clock might skip some seconds. 487 | .PP 488 | There\*(Aqs no check if either format will fit in the given space. 489 | .SH TODO 490 | .IX Header "TODO" 491 | * Full support for multi\-line date\- and time\-formats with auto\-resize. 492 | * Countdown clock API, incl action when done. 493 | * Better docs for the attributes 494 | .SH "SEE ALSO" 495 | .IX Header "SEE ALSO" 496 | \&\fBTk\fR\|(3), \fBTk::Canvas\fR\|(3), \fBTk::Widget\fR\|(3), \fBTk::Derived\fR\|(3) 497 | .SH AUTHOR 498 | .IX Header "AUTHOR" 499 | H.Merijn Brand 500 | .PP 501 | Thanks to Larry Wall for inventing perl. 502 | Thanks to Nick Ing\-Simmons for providing perlTk. 503 | Thanks to Achim Bohnet for introducing me to OO (and converting 504 | the basics of my clock.pl to Tk::Clock.pm). 505 | Thanks to Sriram Srinivasan for understanding OO though his Panther book. 506 | Thanks to all CPAN providers for support of different modules to learn from. 507 | Thanks to all who have given me feedback and weird ideas. 508 | .SH "COPYRIGHT AND LICENSE" 509 | .IX Header "COPYRIGHT AND LICENSE" 510 | Copyright (C) 1999\-2024 H.Merijn Brand 511 | .PP 512 | This library is free software; you can redistribute it and/or modify 513 | it under the same terms as Perl itself. 514 | -------------------------------------------------------------------------------- /sandbox/genMETA.pm: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | package genMETA; 4 | 5 | our $VERSION = "1.16-20240903"; 6 | 7 | use 5.014001; 8 | use warnings; 9 | use Carp; 10 | 11 | use List::Util qw( first ); 12 | use Encode qw( encode decode ); 13 | use Term::ANSIColor qw(:constants); 14 | use Date::Calc qw( Delta_Days ); 15 | use Test::CPAN::Meta::YAML::Version; 16 | use CPAN::Meta::Validator; 17 | use CPAN::Meta::Converter; 18 | use Test::More (); 19 | use Parse::CPAN::Meta; 20 | use File::Find; 21 | use YAML::Syck; 22 | use Data::Peek; 23 | use Text::Diff; 24 | use JSON::PP; 25 | 26 | sub new { 27 | my $package = shift; 28 | return bless { @_ }, $package; 29 | } # new 30 | 31 | sub extract_version { 32 | my $fh = shift; 33 | my @vsn; 34 | while (<$fh>) { 35 | m/\$VERSION\b/ and push @vsn => $_; 36 | m{^(?:our\s+)? # declaration 37 | \$VERSION \s*=\s* # variable 38 | ["']? ([0-9._]+) # version 39 | (?:\s* - \s* [0-9]{4}-?[0-9]{2}-?[0-9]{2} \s*)? # date "0.01 - 20230412" 40 | ['"]? 41 | \s*;\s* 42 | (?:\x23 \s* [0-9]{4}-?[0-9]{2}-?[0-9]{2} \s*)? # date "0.01"; # 20230502 43 | $}x or next; 44 | return $1; 45 | } 46 | # No match on first scan, try without date 47 | for (@vsn) { 48 | m{^(?:our\s+)? # declaration 49 | \$VERSION \s*=\s* # variable 50 | ([""'']) ([0-9._]+) \1 # version 51 | \s*; 52 | }x or next; 53 | return $2; 54 | } 55 | } # extract_version 56 | 57 | sub version_from { 58 | my ($self, $src) = @_; 59 | 60 | $self->{mfpr} = {}; 61 | if (open my $mh, "<", "Makefile.PL") { 62 | my $mf = do { local $/; <$mh> }; 63 | 64 | if ($mf =~ m{\b NAME \s*=>\s* ["'] (\S+) ['"]}x) { 65 | $self->{name} = $1; 66 | $self->{name} =~ m/-/ and 67 | warn RED, "NAME in Makefile.PL contains a -", RESET, "\n"; 68 | $self->{name} =~ s/::/-/g; 69 | } 70 | if ($mf =~ m{\b DISTNAME \s*=>\s* ["'] (\S+) ['"]}x) { 71 | $self->{name} = $1; 72 | } 73 | 74 | if ($mf =~ m{\b VERSION_FROM \s*=>\s* ["'] (\S+) ['"]}x) { 75 | my $from = $1; 76 | -f $from or 77 | croak RED, "Makefile wants version from nonexisten $from", RESET, "\n"; 78 | $self->{from} //= $from; 79 | $from eq $self->{from} or 80 | croak RED, "VERSION_FROM mismatch Makefile.PL ($from) / YAML ($self->{from})", RESET, "\n"; 81 | } 82 | 83 | if ($mf =~ m[\b PREREQ_PM \s*=>\s* \{ ( [^}]+ ) \}]x) { 84 | my @pr = split m/\n/ => $1; 85 | $self->{mfpr} = { map { (m{ \b ["']? (\S+?) ['"]? \s*=>\s* ["']? ([-0-9._]+) ['"]? }x) } grep !m/^\s*#/ => @pr }; 86 | } 87 | 88 | $mf =~ m{--format=ustar} or 89 | warn RED, "TARFLAGS macro is missing", RESET, "\n"; 90 | } 91 | 92 | $src //= $self->{from} or croak "No file to extract version from"; 93 | 94 | open my $pm, "<", $src or croak "Cannot read $src"; 95 | my $version = extract_version ($pm) or croak "Cannot extract VERSION from $src\n"; 96 | close $pm; 97 | $self->{version} = $version; 98 | return $version 99 | } # version_from 100 | 101 | sub from_data { 102 | my ($self, @data) = @_; 103 | $self->{version} or $self->version_from (); 104 | s/VERSION/$self->{version}/g for @data; 105 | my ($dsct, $dmod); 106 | for (@data) { 107 | s/[ \t]+$//; 108 | m/^\s*(\w+):$/ and $dsct = $1; 109 | m/^\s*(\w(?:[\w:]+\w)?):\s+\d/ and $dmod = $1; 110 | s/\s+#\s*ignore\b\s*[:=]?\s*(\S+)$//i or next; 111 | $self->{cve_ignore}{$dsct}{$dmod} = $1; 112 | } 113 | $self->{yml} = \@data; 114 | $self->check_yaml (); 115 | $self->check_provides (); 116 | #DDumper $self->{cve_ignore}; 117 | return @data; 118 | } # from_data 119 | 120 | sub check_encoding { 121 | my $self = shift; 122 | my @tf = grep m{^(?: change | readme | .*\.pod )}ix => glob "*"; 123 | (my $tf = join ", " => @tf) =~ s/.*\K, / and /; 124 | 125 | print "Check if $tf are still valid UTF8 ...\n"; 126 | foreach my $tf (@tf) { 127 | open my $fh, "<", $tf or croak "$tf: $!\n"; 128 | my @c = <$fh>; 129 | my $c = join "" => @c; 130 | my @e; 131 | my $s = decode ("utf-8", $c, sub { push @e, shift; }); 132 | if (@e) { 133 | my @l; 134 | my $n = 0; 135 | for (@c) { 136 | $n++; 137 | eval { decode ("utf-8", $_, 1) }; 138 | $@ or next; 139 | $@ =~ s{ at /\S+ line \d+.*}{}; 140 | print BLUE, "$tf:$n\t$_\t$@", RESET; 141 | } 142 | croak "$tf is not valid UTF-8\n"; 143 | } 144 | my $u = encode ("utf-8", $s); 145 | $c eq $u and next; 146 | 147 | my $n; 148 | $n = 1; $c =~ s/^/$n++ . "\t"/gem; 149 | $n = 1; $u =~ s/^/$n++ . "\t"/gem; 150 | croak "$tf: recode makes content differ\n". diff \$c, \$u; 151 | } 152 | } # check_encoding 153 | 154 | sub check_required { 155 | my $self = shift; 156 | 157 | my $yml = $self->{h} or croak "No YAML to check"; 158 | 159 | warn "Check required and recommended module versions ...\n"; 160 | BEGIN { $V::NO_EXIT = $V::NO_EXIT = 1 } require V; 161 | my %req = map { %{$yml->{$_}} } grep m/requires/ => keys %{$yml}; 162 | my %rec = map { %{$yml->{$_}} } grep m/recommends/ => keys %{$yml}; 163 | my %sug = map { %{$yml->{$_}} } grep m/suggests/ => keys %{$yml}; 164 | if (my $of = $yml->{optional_features}) { 165 | foreach my $f (values %{$of}) { 166 | my %q = map { %{$f->{$_}} } grep m/requires/ => keys %{$f}; 167 | my %c = map { %{$f->{$_}} } grep m/recommends/ => keys %{$f}; 168 | my %s = map { %{$f->{$_}} } grep m/suggests/ => keys %{$f}; 169 | @req{keys %q} = values %q; 170 | @rec{keys %c} = values %c; 171 | @sug{keys %s} = values %s; 172 | } 173 | } 174 | if (my $of = $yml->{prereqs}) { 175 | foreach my $f (values %{$of}) { 176 | my %q = map { %{$f->{$_}} } grep m/requires/ => keys %{$f}; 177 | my %c = map { %{$f->{$_}} } grep m/recommends/ => keys %{$f}; 178 | my %s = map { %{$f->{$_}} } grep m/suggests/ => keys %{$f}; 179 | @req{keys %q} = values %q; 180 | @rec{keys %c} = values %c; 181 | @sug{keys %s} = values %s; 182 | } 183 | } 184 | my %vsn = ( %req, %rec, %sug ); 185 | delete @vsn{qw( perl version )}; 186 | for (sort keys %vsn) { 187 | if (my $mfv = delete $self->{mfpr}{$_}) { 188 | $req{$_} eq $mfv or 189 | croak RED, "PREREQ mismatch for $_ Makefile.PL ($mfv) / YAML ($req{$_})", RESET, "\n"; 190 | } 191 | $vsn{$_} eq "0" and next; 192 | my $v = V::get_version ($_); 193 | $v eq $vsn{$_} and next; 194 | printf STDERR "%s%-35s %-6s => %s%s%s\n", BLUE, $_, $vsn{$_}, GREEN, $v, RESET; 195 | } 196 | if (my @mfpr = grep { $_ ne "version" } sort keys %{$self->{mfpr}}) { 197 | croak RED, "Makefile.PL requires @mfpr, YAML does not", RESET, "\n"; 198 | } 199 | 200 | find (sub { 201 | $File::Find::dir =~ m{^blib\b} and return; 202 | $File::Find::name =~ m{(?:^|/)Bundle/.*\.pm} or return; 203 | if (open my $bh, "<", $_) { 204 | warn "Check bundle module versions $File::Find::name ...\n"; 205 | while (<$bh>) { 206 | my ($m, $dv) = m/^([A-Za-z_:]+)\s+([0-9.]+)\s*$/ or next; 207 | my $v = $m eq $self->{name} ? $self->{version} : V::get_version ($m); 208 | $v eq $dv and next; 209 | printf STDERR "%s%-35s %-6s => %s%s%s\n", BLUE, $m, $dv, GREEN, $v, RESET; 210 | } 211 | } 212 | }, glob "*"); 213 | } # check_required 214 | 215 | sub check_yaml { 216 | my $self = shift; 217 | 218 | my @yml = @{$self->{yml}} or croak "No YAML to check"; 219 | 220 | warn "Checking generated YAML ...\n" unless $self->{quiet}; 221 | my $h; 222 | my $yml = join "", @yml; 223 | eval { $h = Load ($yml) }; 224 | $@ and croak "$@\n"; 225 | $self->{name} //= $h->{name}; 226 | $self->{name} eq $h->{name} or 227 | croak RED, "NAME mismatch Makefile.PL / YAML", RESET, "\n"; 228 | $self->{name} =~ s/-/::/g; 229 | warn "Checking for $self->{name}-$self->{version}\n" unless $self->{quiet}; 230 | 231 | $self->{verbose} and print Dump $h; 232 | 233 | my $t = Test::CPAN::Meta::YAML::Version->new (data => $h); 234 | $t->parse () and 235 | croak join "\n", "Test::CPAN::Meta::YAML reported failure:", $t->errors, ""; 236 | 237 | eval { Parse::CPAN::Meta::Load ($yml) }; 238 | $@ and croak "$@\n"; 239 | 240 | $self->{h} = $h; 241 | $self->{yaml} = $yml; 242 | } # check_yaml 243 | 244 | sub check_minimum { 245 | my $self = shift; 246 | my $reqv = $self->{h}{requires}{perl} || $self->{h}{prereqs}{runtime}{requires}{perl}; 247 | my $locs; 248 | 249 | for (@_) { 250 | if (ref $_ eq "ARRAY") { 251 | $locs = { paths => $_ }; 252 | } 253 | elsif (ref $_ eq "HASH") { 254 | $locs = $_; 255 | } 256 | else { 257 | $reqv = $_; 258 | } 259 | } 260 | my $paths = (join ", " => @{($locs // {})->{paths} // []}) || "default paths"; 261 | 262 | $reqv or croak "No minimal required version for perl"; 263 | my $tmv = 0; 264 | $reqv > 5.009 and eval "use Test::MinimumVersion::Fast; \$tmv = 1"; 265 | $tmv or eval "use Test::MinimumVersion;"; 266 | print "Checking if $reqv is still OK as minimal version for $paths\n"; 267 | # All other minimum version checks done in xt 268 | Test::More::subtest "Minimum perl version $reqv" => sub { 269 | all_minimum_version_ok ($reqv, $locs); 270 | } or warn RED, "\n### Use 'perlver --blame' on the failing file(s)\n\n", RESET; 271 | } # check_minimum 272 | 273 | sub check_provides { 274 | my $self = shift; 275 | my $prov = $self->{h}{provides}; 276 | 277 | print "Check distribution module versions ...\n"; 278 | 279 | $prov or croak RED, "META does not contain a provides section", RESET, "\n"; 280 | 281 | ref $prov eq "HASH" or 282 | croak RED, "The provides section in META is not a HASH", RESET, "\n"; 283 | 284 | my $fail = 0; 285 | foreach my $m (sort keys %{$prov}) { 286 | my ($file, $pvsn) = @{$prov->{$m}}{qw( file version )}; 287 | unless ($file) { 288 | $fail++; 289 | say RED, " provided $m does not refer to a file", RESET; 290 | next; 291 | } 292 | unless ($pvsn) { 293 | $fail++; 294 | say RED, " provided $m does not declare a version", RESET; 295 | next; 296 | } 297 | 298 | printf " Expect %5s for %-32s ", $pvsn, $m; 299 | open my $fh, "<", $file; 300 | unless ($fh) { 301 | $fail++; 302 | say RED, "$file: $!\n", RESET; 303 | next; 304 | } 305 | 306 | my $version = extract_version ($fh); 307 | close $fh; 308 | unless ($version) { 309 | $fail++; 310 | say RED, "$file does not contain a VERSION", RESET; 311 | next; 312 | } 313 | 314 | if ($version ne $pvsn) { 315 | $fail++; 316 | say RED, "mismatch: $version", RESET; 317 | next; 318 | } 319 | say "ok"; 320 | } 321 | 322 | $fail and exit 1; 323 | } # check_provides 324 | 325 | sub check_changelog { 326 | # Check if the first date has been updated ... 327 | my @td = grep m/^Change(?:s|Log)$/i => glob "[Cc]*"; 328 | unless (@td) { 329 | warn "No ChangeLog to check\n"; 330 | return; 331 | } 332 | my %mnt = qw( jan 1 feb 2 mar 3 apr 4 may 5 jun 6 jul 7 aug 8 sep 9 oct 10 nov 11 dec 12 ); 333 | open my $fh, "<", $td[0] or croak "$td[0]: $!\n"; 334 | while (<$fh>) { 335 | s/\b([0-9]{4}) (?:[- ]) 336 | ([0-9]{1,2}) (?:[- ]) 337 | ([0-9]{1,2})\b/$3-$2-$1/x; # 2015-01-15 => 15-01-2015 338 | m/\b([0-9]{1,2}) (?:[- ]) 339 | ([0-9]{1,2}|[ADFJMNOSadfjmnos][acekopu][abcgilnprtvy]) (?:[- ]) 340 | ([0-9]{4})\b/x or next; 341 | my ($d, $m, $y) = ($1 + 0, ($mnt{lc $2} || $2) + 0, $3 + 0); 342 | printf STDERR "Most recent ChangeLog entry is dated %02d-%02d-%04d\n", $d, $m, $y; 343 | unless ($ENV{SKIP_CHANGELOG_DATE}) { 344 | my @t = localtime; 345 | my $D = Delta_Days ($y, $m , $d, $t[5] + 1900, $t[4] + 1, $t[3]); 346 | $D < 0 and croak RED, "Last entry in $td[0] is in the future!", RESET, "\n"; 347 | $D > 2 and croak RED, "Last entry in $td[0] is not up to date ($D days ago)", RESET, "\n"; 348 | $D > 0 and warn YELLOW, "Last entry in $td[0] is not today", RESET, "\n"; 349 | } 350 | last; 351 | } 352 | close $fh; 353 | } # check_changelog 354 | 355 | sub done_testing { 356 | check_changelog (); 357 | Test::More::done_testing (); 358 | } # done_testing 359 | 360 | sub quiet { 361 | my $self = shift; 362 | @_ and $self->{quiet} = defined $_[0]; 363 | $self->{quiet}; 364 | } # quiet 365 | 366 | sub print_json { 367 | my $self = shift; 368 | my $jsn = $self->{jsn} || $self->add_json (); 369 | print JSON::PP->new->utf8 (1)->pretty (1)->encode ($jsn); 370 | } # print_json 371 | 372 | sub print_yaml { 373 | my $self = shift; 374 | print @{$self->{yml}}; 375 | } # print_yaml 376 | 377 | sub write_yaml { 378 | my ($self, $out) = @_; 379 | $out ||= "META.yml"; 380 | $out =~ s/\.jso?n$/.yml/; 381 | open my $fh, ">", $out or croak "$out: $!\n"; 382 | print $fh @{$self->{yml}}; 383 | close $fh; 384 | $self->fix_meta ($out); 385 | } # print_yaml 386 | 387 | sub add_json { 388 | my $self = shift; 389 | # Convert to meta-spec version 2 390 | # licenses are lists now 391 | my $jsn = $self->{h}; 392 | $jsn->{"meta-spec"} = { 393 | version => "2", 394 | url => "https://metacpan.org/module/CPAN::Meta::Spec?#meta-spec", 395 | }; 396 | exists $jsn->{resources}{license} and 397 | $jsn->{resources}{license} = [ $jsn->{resources}{license} ]; 398 | delete $jsn->{distribution_type}; 399 | if (exists $jsn->{license}) { 400 | if (ref $jsn->{license} eq "ARRAY") { 401 | $jsn->{license}[0] =~ s/^perl$/perl_5/i; 402 | } 403 | else { 404 | $jsn->{license} =~ s/^perl$/perl_5/i; 405 | $jsn->{license} = [ $jsn->{license} ]; 406 | } 407 | } 408 | if (exists $jsn->{resources}{bugtracker}) { 409 | my $url = $jsn->{resources}{bugtracker}; 410 | $jsn->{resources}{bugtracker} = { 411 | web => $url, 412 | }; 413 | } 414 | if (exists $jsn->{resources}{repository}) { 415 | my $url = $jsn->{resources}{repository}; 416 | my $web = $url; 417 | $url =~ s{repo.or.cz/w/}{repo.or.cz/r/}; 418 | $web =~ s{repo.or.cz/r/}{repo.or.cz/w/}; 419 | $jsn->{resources}{repository} = { 420 | type => "git", 421 | web => $web, 422 | url => $url, 423 | }; 424 | } 425 | foreach my $sct ("", "configure_", "build_", "test_") { 426 | (my $x = $sct || "runtime") =~ s/_$//; 427 | for (qw( requires recommends suggests )) { 428 | exists $jsn->{"$sct$_"} and 429 | $jsn->{prereqs}{$x}{$_} = delete $jsn->{"$sct$_"}; 430 | } 431 | } 432 | 433 | # optional features do not yet know about requires and/or recommends diirectly 434 | if (my $of = $jsn->{optional_features}) { 435 | foreach my $f (keys %$of) { 436 | if (my $r = delete $of->{$f}{requires}) { 437 | #$jsn->{prereqs}{runtime}{recommends}{$_} //= $r->{$_} for keys %$r; 438 | $of->{$f}{prereqs}{runtime}{requires} = $r; 439 | } 440 | if (my $r = delete $of->{$f}{recommends}) { 441 | #$jsn->{prereqs}{runtime}{recommends}{$_} //= $r->{$_} for keys %$r; 442 | $of->{$f}{prereqs}{runtime}{recommends} = $r; 443 | } 444 | if (my $r = delete $of->{$f}{suggests}) { 445 | #$jsn->{prereqs}{runtime}{suggests}{$_} //= $r->{$_} for keys %$r; 446 | $of->{$f}{prereqs}{runtime}{suggests} = $r; 447 | } 448 | } 449 | } 450 | 451 | $jsn = CPAN::Meta::Converter->new ($jsn)->convert (version => "2"); 452 | $jsn->{generated_by} = "Author"; 453 | $self->{jsn} = $jsn; 454 | } # add_json 455 | 456 | sub fix_meta { 457 | my ($self, $yf) = @_; 458 | 459 | my $jsn = $self->add_json (); 460 | 461 | my $cmv = CPAN::Meta::Validator->new ($jsn); 462 | $cmv->is_valid or 463 | croak join "\n" => RED, "META Validator found fail:\n", $cmv->errors, RESET, ""; 464 | 465 | unless ($yf) { 466 | my @my = grep { -s } glob ("*/META.yml"), "META.yml" or croak "No META files"; 467 | $yf = $my[0]; 468 | } 469 | my $jf = $yf =~ s/yml$/json/r; 470 | open my $jh, ">", $jf or croak "Cannot update $jf: $!\n"; 471 | print $jh JSON::PP->new->utf8 (1)->pretty (1)->encode ($jsn); 472 | close $jh; 473 | 474 | # Now that 2.0 JSON is corrrect, create a 1.4 YAML back from the modified stuff 475 | my $yml = $jsn; 476 | # 1.4 does not know about test_*, move them to * 477 | if (my $tp = delete $yml->{prereqs}{test}) { 478 | foreach my $phase (keys %{$tp}) { 479 | my $p = $tp->{$phase}; 480 | #DDumper { $phase => $p }; 481 | $yml->{prereqs}{runtime}{$phase}{$_} //= $p->{$_} for keys %{$p}; 482 | } 483 | } 484 | 485 | # Optional features in 1.4 knows requires, but not recommends. 486 | # The Lancaster Consensus moves 2.0 optional recommends promote to 487 | # requires in 1.4 488 | if (my $of = $yml->{optional_features}) { 489 | foreach my $f (keys %$of) { 490 | if (my $r = delete $of->{$f}{prereqs}{runtime}{recommends}) { 491 | $of->{$f}{requires} = $r; 492 | } 493 | if (my $r = delete $of->{$f}{prereqs}{runtime}{suggests}) { 494 | $of->{$f}{suggests} = $r; 495 | } 496 | } 497 | } 498 | # runtime and test_requires are unknown as top-level in 1.4 499 | foreach my $phase (qw( xuntime test_requires )) { 500 | if (my $p = delete $yml->{$phase}) { 501 | foreach my $f (keys %$p) { 502 | $yml->{$f}{$_} ||= $p->{$f}{$_} for keys %{$p->{$f}}; 503 | } 504 | } 505 | } 506 | 507 | #DDumper $yml; 508 | # This does NOT create a correct YAML id the source does not comply! 509 | $yml = CPAN::Meta::Converter->new ($yml)->convert (version => "1.4"); 510 | $yml->{requires}{perl} //= $jsn->{prereqs}{runtime}{requires}{perl} 511 | // $self->{h}{requires}{perl} 512 | // ""; 513 | $yml->{build_requires} && !keys %{$yml->{build_requires}} and 514 | delete $yml->{build_requires}; 515 | #DDumper $yml; 516 | #exit; 517 | 518 | open my $my, ">", $yf or croak "Cannot update $yf: $!\n"; 519 | print $my Dump $yml; # @{$self->{yml}}; 520 | close $my; 521 | 522 | chmod 0644, glob "*/META.*"; 523 | unlink glob "MYMETA*"; 524 | } # fix_meta 525 | 526 | sub _cpfd { 527 | my ($self, $jsn, $sct, $f) = @_; 528 | 529 | open my $sh, ">", \my $b; 530 | my $sep = ""; 531 | for (qw( requires recommends suggests )) { 532 | my $x = "$sct$_"; 533 | my $s = $jsn->{$x} or next; 534 | print $sh $sep; 535 | foreach my $m (sort keys %$s) { 536 | $m eq "perl" and next; 537 | my $v = $s->{$m}; 538 | printf $sh qq{%-10s "%s"}, $_, $m; 539 | my $aw = (24 - length $m); $aw < 0 and $aw = 0; 540 | printf $sh qq{%s => "%s"}, " " x $aw, $v if $v; 541 | print $sh ";"; 542 | if (my $i = $self->{cve_ignore}{$x}{$m}) { 543 | print $sh " # ignore : $i"; 544 | } 545 | say $sh ""; 546 | } 547 | $sep = "\n"; 548 | } 549 | close $sh; 550 | $sct || $f and $b and $b .= "};"; 551 | return $b; 552 | } # _cpfd 553 | 554 | sub gen_cpanfile { 555 | my $self = shift; 556 | 557 | warn "Generating cpanfile ...\n"; 558 | open my $fh, ">", "cpanfile"; 559 | 560 | my $jsn = $self->{h}; 561 | foreach my $sct_ ("", "configure_", "build_", "test_", "runtime_") { 562 | 563 | my $sct = $sct_ =~ s/_$//r; 564 | 565 | my $b = _cpfd ($self, $jsn, $sct_, 0) or next; 566 | 567 | if ($sct) { 568 | say $fh qq/\non "$sct" => sub {/; 569 | say $fh $b =~ s/^(?=\S)/ /gmr; 570 | } 571 | else { 572 | print $fh $b; 573 | } 574 | } 575 | 576 | if (my $of = $jsn->{optional_features}) { 577 | foreach my $f (sort keys %$of) { 578 | my $fs = $of->{$f}; 579 | say $fh qq/\nfeature "$f", "$fs->{description}" => sub {/; 580 | say $fh _cpfd ($self, $fs, "", 1) =~ s/^(?=\S)/ /gmr; 581 | } 582 | } 583 | 584 | close $fh; 585 | 586 | warn "Check CVE's ...\n"; 587 | if (system "cpan-cve.pl", "-d", ".") { 588 | warn "### CVE WARNING\n"; 589 | warn "#\n"; 590 | warn "# The current release would have recommended versions\n"; 591 | warn "# with known CVE's that are not (yet) ignored\n"; 592 | sleep (5); 593 | } 594 | } # gen_cpanfile 595 | 596 | 1; 597 | -------------------------------------------------------------------------------- /Clock.pm: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | package Tk::Clock; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | our $VERSION = "0.45"; 9 | 10 | use Carp; 11 | 12 | use Tk; 13 | use Tk::Widget; 14 | use Tk::Derived; 15 | use Tk::Canvas; 16 | 17 | use vars qw( @ISA ); 18 | @ISA = qw/Tk::Derived Tk::Canvas/; 19 | 20 | Construct Tk::Widget "Clock"; 21 | 22 | my $ana_base = 73; # Size base for 100% 23 | 24 | my %def_config = ( 25 | timeZone => "", 26 | useLocale => "C", 27 | backDrop => "", 28 | 29 | useAnalog => 1, 30 | 31 | handColor => "Green4", 32 | secsColor => "Green2", 33 | tickColor => "Yellow4", 34 | tickFreq => 1, 35 | tickDiff => 0, 36 | useSecHand => 1, 37 | handCenter => 0, 38 | 39 | anaScale => 100, 40 | autoScale => 0, 41 | 42 | ana24hour => 0, 43 | countDown => 0, 44 | timerValue => 0, 45 | localOffset => 0, 46 | 47 | useInfo => 0, 48 | 49 | infoColor => "#cfb53b", 50 | infoFormat => "HH:MM:SS", 51 | infoFont => "fixed 6", 52 | 53 | useText => 0, 54 | 55 | textColor => "#c4c4c4", 56 | textFormat => " ", 57 | textFont => "fixed 6", 58 | 59 | time2Font => "fixed 6", 60 | time2Color => "Gray30", 61 | time2Format => "", 62 | time2TZ => "", 63 | 64 | useDigital => 1, 65 | 66 | digiAlign => "center", 67 | 68 | timeFont => "fixed 6", 69 | timeColor => "Red4", 70 | timeFormat => "HH:MM:SS", 71 | 72 | dateFont => "fixed 6", 73 | dateColor => "Blue4", 74 | dateFormat => "dd-mm-yy", 75 | 76 | fmtd => sub { 77 | sprintf "%02d-%02d-%02d", $_[3], $_[4] + 1, $_[5] + 1900; 78 | }, 79 | fmtt => sub { 80 | sprintf "%02d:%02d:%02d", @_[2,1,0]; 81 | }, 82 | fmti => sub { 83 | sprintf "%02d:%02d:%02d", @_[2,1,0]; 84 | }, 85 | fmt2 => sub { 86 | sprintf "%02d:%02d:%02d", @_[2,1,0]; 87 | }, 88 | 89 | _anaSize => $ana_base, # Default size (height & width) 90 | _digSize => 26, # Height 91 | _digWdth => 72, # Width 92 | ); 93 | 94 | my %locale = ( 95 | C => { 96 | month => [ 97 | # m mm mmm mmmm 98 | [ "1", "01", "Jan", "January" ], 99 | [ "2", "02", "Feb", "February" ], 100 | [ "3", "03", "Mar", "March" ], 101 | [ "4", "04", "Apr", "April" ], 102 | [ "5", "05", "May", "May" ], 103 | [ "6", "06", "Jun", "June" ], 104 | [ "7", "07", "Jul", "July" ], 105 | [ "8", "08", "Aug", "August" ], 106 | [ "9", "09", "Sep", "September"], 107 | [ "10", "10", "Oct", "October" ], 108 | [ "11", "11", "Nov", "November" ], 109 | [ "12", "12", "Dec", "December" ], 110 | ], 111 | day => [ 112 | # ddd dddd 113 | [ "Sun", "Sunday" ], 114 | [ "Mon", "Monday" ], 115 | [ "Tue", "Tuesday" ], 116 | [ "Wed", "Wednesday" ], 117 | [ "Thu", "Thursday" ], 118 | [ "Fri", "Friday" ], 119 | [ "Sat", "Saturday" ], 120 | ], 121 | }, 122 | ); 123 | 124 | sub _booleans { 125 | my $data = shift; 126 | $data->{$_} = !!$data->{$_} for qw( 127 | ana24hour 128 | autoScale 129 | countDown 130 | handCenter 131 | useAnalog 132 | useDigital 133 | useInfo 134 | useText 135 | useSecHand 136 | ); 137 | } # _booleans 138 | 139 | sub _decode { 140 | my $s = shift; 141 | $s && $s =~ m{[\x80-\xff]} or return $s; 142 | my $u = eval { Encode::decode ("UTF-8", $s, Encode::FB_CROAK) }; 143 | return ($@ ? $s : $u); 144 | } # _decode 145 | 146 | sub _newLocale { 147 | my $locale = shift or return $locale{C}; 148 | 149 | require POSIX; 150 | require Encode; 151 | 152 | my $curloc = POSIX::setlocale (POSIX::LC_TIME (), "") || "C"; 153 | my $newloc = POSIX::setlocale (POSIX::LC_TIME (), $locale) || "C"; 154 | $locale{$newloc} and return $locale{$newloc}; 155 | 156 | my $l = $locale{$locale} = {}; 157 | foreach my $m (0 .. 11) { 158 | @{$l->{month}[$m]} = map { _decode ($_) } 159 | $m + 1, $locale{C}{month}[$m][1], 160 | POSIX::strftime ("%b", 0, 0, 0, 1, $m, 113), 161 | POSIX::strftime ("%B", 0, 0, 0, 1, $m, 113); 162 | } 163 | foreach my $d (0 .. 6) { 164 | @{$l->{day}[$d]} = map { _decode ($_) } 165 | POSIX::strftime ("%a", 0, 0, 0, $d - 1, 0, 113), 166 | POSIX::strftime ("%A", 0, 0, 0, $d - 1, 0, 113); 167 | } 168 | 169 | POSIX::setlocale (POSIX::LC_TIME (), $curloc); 170 | 171 | return $l; 172 | } # _newLocale 173 | 174 | sub _month { # (month, size) 175 | my ($locale, $m, $l) = @_; 176 | ($locale{$locale} || $locale{C})->{month}[$m][$l]; 177 | } # _month 178 | 179 | sub _wday { # (wday, size) 180 | my ($locale, $m, $l) = @_; 181 | ($locale{$locale} || $locale{C})->{day}[$m][$l]; 182 | } # _wday 183 | 184 | sub _min { 185 | $_[0] <= $_[1] ? $_[0] : $_[1]; 186 | } # _min 187 | 188 | sub _max { 189 | $_[0] >= $_[1] ? $_[0] : $_[1]; 190 | } # _max 191 | 192 | # Transparent packInfo for pack/grid/place/form 193 | sub _packinfo { 194 | my $clock = shift; 195 | 196 | my %pi = map { ("-$_" => 0) } qw( padx pady ipadx ipady ); 197 | if (my $pm = $clock->manager) { 198 | if ($pm eq "pack") { 199 | %pi = $clock->packInfo; 200 | } 201 | elsif ($pm eq "grid") { 202 | %pi = $clock->gridInfo; 203 | } 204 | elsif ($pm eq "form") { 205 | %pi = $clock->formInfo; 206 | # padx pady padleft padright padtop padbottom 207 | $pi{"-ipadx"} = int (((delete $pi{"-padleft"}) + (delete $pi{"-padright"} )) / 2); 208 | $pi{"-ipady"} = int (((delete $pi{"-padtop"} ) + (delete $pi{"-padbottom"})) / 2); 209 | } 210 | elsif ($pm eq "place") { 211 | # No action, place has no padding 212 | } 213 | else { 214 | # No action, unknown geometry manager 215 | } 216 | } 217 | %pi; 218 | } # _packinfo 219 | 220 | sub _resize { 221 | my $clock = shift; 222 | 223 | use integer; 224 | my $data = $clock->privateData; 225 | my $hght = $data->{useAnalog} * $data->{_anaSize} + 226 | $data->{useDigital} * $data->{_digSize} + 1; 227 | my $wdth = _max ($data->{useAnalog} * $data->{_anaSize}, 228 | $data->{useDigital} * $data->{_digWdth}); 229 | my $dim = "${wdth}x${hght}"; 230 | my $geo = $clock->parent->geometry; 231 | my ($pw, $ph) = split m/\D/, $geo; # Cannot use ->cget here 232 | if ($ph > 5 && $clock->parent->isa ("MainWindow")) { 233 | my %pi = $clock->_packinfo; 234 | my $px = _max ($wdth + $pi{"-padx"}, $pw); 235 | my $py = _max ($hght + $pi{"-pady"}, $ph); 236 | $clock->parent->geometry ("${px}x$py"); 237 | } 238 | $clock->configure ( 239 | -height => $hght, 240 | -width => $wdth); 241 | $dim; 242 | } # _resize 243 | 244 | # Callback when auto-resize is called 245 | sub _resize_auto { 246 | my $clock = shift; 247 | my $data = $clock->privateData; 248 | 249 | $data->{useAnalog} && $data->{autoScale} == 1 or return; 250 | 251 | my $owdth = $data->{useAnalog} * $data->{_anaSize}; 252 | my $geo = $clock->geometry; 253 | my ($gw, $gh) = split m/\D/, $geo; # Cannot use ->cget here 254 | $gw < 5 and return; # not packed yet? 255 | $data->{useDigital} and $gh -= $data->{_digSize}; 256 | my $nwdth = _min ($gw, $gh - 1); 257 | abs ($nwdth - $owdth) > 5 && $nwdth >= 10 or return; 258 | 259 | $data->{_anaSize} = $nwdth - 2; 260 | $clock->_destroyAnalog; 261 | $clock->_createAnalog; 262 | if ($data->{useDigital}) { 263 | # Otherwise the digital either overlaps the analog 264 | # or there is a gap 265 | $clock->_destroyDigital; 266 | $clock->_createDigital; 267 | } 268 | $clock->_resize; 269 | } # _resize_auto 270 | 271 | sub _createDigital { 272 | my $clock = shift; 273 | 274 | my $data = $clock->privateData; 275 | 276 | # Dynamically determine the size of the digital display 277 | my @t = localtime (time + $data->{localOffset}); 278 | my ($wd, $hd) = do { 279 | my $s_date = $data->{fmtd}->(@t, 0, 0, 0); 280 | $s_date =~ s/\b([0-9])\b/0$1/g; # prepare "d" running from 9 to 10 281 | my $f = $clock->Label (-font => $data->{dateFont})->cget (-font); 282 | my %fm = $clock->fontMetrics ($f); 283 | ($clock->fontMeasure ($f, $s_date), $fm{"-linespace"} || 9); 284 | }; 285 | my ($wt, $ht) = do { 286 | my $s_time = $data->{fmtt}->(@t, 0, 0, 0); 287 | $s_time =~ s/\b([0-9])\b/0$1/g; # prepare "h" running from 9 to 10 288 | my $f = $clock->Label (-font => $data->{timeFont})->cget (-font); 289 | my %fm = $clock->fontMetrics ($f); 290 | ($clock->fontMeasure ($f, $s_time), $fm{"-linespace"} || 9); 291 | }; 292 | my $w = _max (72, int (1.1 * _max ($wt, $wd))); 293 | $data->{_digSize} = $hd + 4 + $ht + 4; # height of date + time 294 | $data->{_digWdth} = $w; 295 | 296 | my $wdth = _max ($data->{useAnalog} * $data->{_anaSize}, 297 | $data->{useDigital} * $w); 298 | my ($pad, $anchor) = (5, "s"); 299 | my ($x, $y) = ($wdth / 2, $data->{useAnalog} * $data->{_anaSize}); 300 | if ($data->{digiAlign} eq "left") { 301 | ($anchor, $x) = ("sw", $pad); 302 | } 303 | elsif ($data->{digiAlign} eq "right") { 304 | ($anchor, $x) = ("se", $wdth - $pad); 305 | } 306 | $clock->createText ($x, $y + $ht + 4 + $hd, 307 | -anchor => $anchor, 308 | -width => ($wdth - 2 * $pad), 309 | -font => $data->{dateFont}, 310 | -fill => $data->{dateColor}, 311 | -text => $data->{dateFormat}, 312 | -tags => "date"); 313 | $clock->createText ($x, $y + $ht + 2, 314 | -anchor => $anchor, 315 | -width => ($wdth - 2 * $pad), 316 | -font => $data->{timeFont}, 317 | -fill => $data->{timeColor}, 318 | -text => $data->{timeFormat}, 319 | -tags => "time"); 320 | # $data->{Clock_h} = -1; 321 | # $data->{Clock_m} = -1; 322 | # $data->{Clock_s} = -1; 323 | $clock->_resize; 324 | } # _createDigital 325 | 326 | sub _destroyDigital { 327 | my $clock = shift; 328 | 329 | $clock->delete ("date"); 330 | $clock->delete ("time"); 331 | } # _destroyDigital 332 | 333 | sub _where { 334 | my ($clock, $tick, $len, $anaSize) = @_; # ticks 0 .. 59 335 | my ($x, $y, $angle); 336 | 337 | $clock->privateData->{countDown} and $tick = (60 - $tick) % 60; 338 | my $h = ($anaSize + 1) / 2; 339 | $angle = $tick * .104720; 340 | $x = $len * sin ($angle) * $anaSize / 73; 341 | $y = $len * cos ($angle) * $anaSize / 73; 342 | ($h - $x / 4, $h + $y / 4, $h + $x, $h - $y); 343 | } # _where 344 | 345 | sub _timeText { 346 | my ($data, $tag) = @_; 347 | my $tf = $data->{"${tag}Format"}; 348 | local $ENV{TZ} = $data->{"${tag}TZ"} || $data->{timeZone} || $ENV{TZ}; 349 | my $text = ref $tf eq "CODE" ? $tf->(localtime) 350 | : ref $tf eq "SCALAR" ? $$tf : $tf; 351 | return $text; 352 | } # _timeText 353 | 354 | sub _createTimeText { 355 | my ($clock, $data, $tag, $h, $f) = @_; 356 | my $text = _timeText ($data, $tag); 357 | $clock->createText ($h, int ($f * $h), 358 | -anchor => "n", 359 | -width => int (1.2 * $h), 360 | -font => $data->{"${tag}Font"}, 361 | -fill => $data->{"${tag}Color"}, 362 | -text => $text, 363 | -tags => $tag); 364 | } # _createTimeText 365 | 366 | sub _createAnalog { 367 | my $clock = shift; 368 | 369 | my $data = $clock->privateData; 370 | 371 | ref $data->{backDrop} eq "Tk::Photo" and 372 | $clock->createImage (0, 0, 373 | -anchor => "nw", 374 | -image => $data->{backDrop}, 375 | -tags => "back", 376 | ); 377 | 378 | my $h = ($data->{_anaSize} + 1) / 2 - 1; 379 | 380 | if ($data->{useInfo}) { 381 | $clock->createText ($h, int (1.3 * $h), 382 | -anchor => "n", 383 | -width => int (1.2 * $h), 384 | -font => $data->{infoFont}, 385 | -fill => $data->{infoColor}, 386 | -text => $data->{infoFormat}, 387 | -tags => "info"); 388 | } 389 | if ($data->{useText}) { 390 | _createTimeText ($clock, $data, "text", $h, 1.5); 391 | } 392 | if ($data->{time2TZ}) { 393 | $data->{time2TZ} ||= "UTC"; 394 | $data->{time2Format} or $clock->config (time2Format => "HH:MM:SS"); 395 | unless (ref $data->{time2Format}) { 396 | ref $data->{fmt2} and $data->{time2Format} = $data->{fmt2}; 397 | } 398 | _createTimeText ($clock, $data, "time2", $h, 0.7); 399 | } 400 | else { 401 | $data->{time2Format} = ""; 402 | } 403 | 404 | my $f = $data->{tickFreq} * 2; 405 | foreach my $dtick (0 .. 119) { 406 | $dtick % $f and next; 407 | my $l = $dtick % 30 == 0 ? $h / 5 : 408 | $dtick % 10 == 0 ? $h / 8 : 409 | $h / 16; 410 | my $angle = ($dtick / 2) * .104720; 411 | my $x = sin $angle; 412 | my $y = cos $angle; 413 | $clock->createLine ( 414 | ($h - $l) * $x + $h + 1, ($h - $l) * $y + $h + 1, 415 | $h * $x + $h + 1, $h * $y + $h + 1, 416 | -tags => "tick", 417 | -arrow => "none", 418 | -fill => $data->{tickColor}, 419 | -width => $data->{tickDiff} && $dtick % 10 == 0 ? 4.0 : 1.0, 420 | ); 421 | } 422 | $data->{Clock_h} = -1; 423 | $data->{Clock_m} = -1; 424 | $data->{Clock_s} = -1; 425 | 426 | $clock->createLine ( 427 | $clock->_where (0, 22, $data->{_anaSize}), 428 | -tags => "hour", 429 | -arrow => "none", 430 | -fill => $data->{handColor}, 431 | -width => $data->{_anaSize} / ($data->{handCenter} ? 35 : 26), 432 | ); 433 | if ($data->{handCenter}) { 434 | my $cntr = $data->{_anaSize} / 2; 435 | my $diam = $data->{_anaSize} / 30; 436 | $clock->createOval (($cntr - $diam) x 2, ($cntr + $diam) x 2, 437 | -tags => "hour", 438 | -fill => $data->{handColor}, 439 | -width => 0, 440 | ); 441 | } 442 | $clock->createLine ( 443 | $clock->_where (0, 30, $data->{_anaSize}), 444 | -tags => "min", 445 | -arrow => "none", 446 | -fill => $data->{handColor}, 447 | -width => $data->{_anaSize} / ($data->{handCenter} ? 60 : 30), 448 | ); 449 | if ($data->{useSecHand}) { 450 | $clock->createLine ( 451 | $clock->_where (0, 34, $data->{_anaSize}), 452 | -tags => "sec", 453 | -arrow => "none", 454 | -fill => $data->{secsColor}, 455 | -width => 0.8); 456 | if ($data->{handCenter}) { 457 | my $cntr = $data->{_anaSize} / 2; 458 | my $diam = $data->{_anaSize} / 35; 459 | $clock->createOval (($cntr - $diam) x 2, ($cntr + $diam) x 2, 460 | -tags => "sec", 461 | -fill => $data->{secsColor}, 462 | -width => 0, 463 | ); 464 | } 465 | } 466 | 467 | $clock->_resize; 468 | } # _createAnalog 469 | 470 | sub _destroyAnalog { 471 | my $clock = shift; 472 | 473 | $clock->delete ($_) for qw( back text info time2 tick hour min sec ); 474 | } # _destroyAnalog 475 | 476 | sub Populate { 477 | my ($clock, $args) = @_; 478 | 479 | my $data = $clock->privateData; 480 | %$data = %def_config; 481 | $data->{Clock_h} = -1; 482 | $data->{Clock_m} = -1; 483 | $data->{Clock_s} = -1; 484 | $data->{_time_} = -1; 485 | 486 | if (ref $args eq "HASH") { 487 | foreach my $arg (keys %$args) { 488 | (my $attr = $arg) =~ s/^-//; 489 | $attr =~ m/^_/ and next; # Internal use only! 490 | exists $data->{$attr} and $data->{$attr} = delete $args->{$arg}; 491 | } 492 | } 493 | _booleans ($data); 494 | 495 | $clock->SUPER::Populate ($args); 496 | 497 | $clock->ConfigSpecs ( 498 | -width => [ qw(SELF width Width 72 ) ], 499 | -height => [ qw(SELF height Height 100 ) ], 500 | -relief => [ qw(SELF relief Relief raised) ], 501 | -borderwidth => [ qw(SELF borderWidth BorderWidth 1 ) ], 502 | -highlightthickness => [ qw(SELF highlightThickness HighlightThickness 0 ) ], 503 | -takefocus => [ qw(SELF takefocus Takefocus 0 ) ], 504 | ); 505 | 506 | $data->{useAnalog} and $clock->_createAnalog; 507 | $data->{useDigital} and $clock->_createDigital; 508 | $clock->_resize; 509 | 510 | $clock->repeat (995, ["_run" => $clock]); 511 | } # Populate 512 | 513 | my %attr_weight = ( 514 | useDigital => 99980, 515 | digiAlign => 99985, 516 | useAnalog => 99990, 517 | useInfo => 99991, 518 | useText => 99991, 519 | time2TZ => 99991, 520 | tickFreq => 99992, 521 | anaScale => 99995, 522 | useLocale => 1, 523 | ); 524 | 525 | sub config { 526 | my $clock = shift; 527 | 528 | ref $clock or croak "Bad method call"; 529 | @_ or return; 530 | 531 | my $conf; 532 | if (ref $_[0] eq "HASH") { 533 | $conf = shift; 534 | } 535 | elsif (scalar @_ % 2 == 0) { 536 | my %conf = @_; 537 | $conf = \%conf; 538 | } 539 | else { 540 | croak "Bad hash"; 541 | } 542 | 543 | # -anaScale -> anaScale 544 | for (grep m/^-(\w+)$/ => keys %$conf) { 545 | (my $attr = $_) =~ s/^-//; 546 | $conf->{$attr} = delete $conf->{$_}; 547 | } 548 | 549 | my $data = $clock->privateData; 550 | my $pfmt = $] < 5.010 ? "s" : "s>"; 551 | $attr_weight{$_} ||= unpack $pfmt, $_ for keys %def_config; 552 | 553 | my $autoScale; 554 | # sort, so the recreational attribute will be done last 555 | foreach my $conf_spec ( 556 | map { $_->[0] } 557 | sort { $a->[1] <=> $b->[1] } 558 | map { [ $_, $attr_weight{$_} ] } 559 | keys %$conf) { 560 | (my $attr = $conf_spec) =~ s/^-//; 561 | $attr =~ m/^_/ and next; # Internal use only! 562 | exists $def_config{$attr} && exists $data->{$attr} or next; 563 | my $old = $data->{$attr}; 564 | $data->{$attr} = $conf->{$conf_spec}; 565 | if ($attr eq "tickColor") { 566 | $clock->itemconfigure ("tick", -fill => $data->{tickColor}); 567 | } 568 | elsif ($attr eq "handColor") { 569 | $clock->itemconfigure ("hour", -fill => $data->{handColor}); 570 | $clock->itemconfigure ("min", -fill => $data->{handColor}); 571 | } 572 | elsif ($attr eq "secsColor") { 573 | $clock->itemconfigure ("sec", -fill => $data->{secsColor}); 574 | } 575 | elsif ($attr eq "dateColor") { 576 | $clock->itemconfigure ("date", -fill => $data->{dateColor}); 577 | } 578 | elsif ($attr eq "dateFont") { 579 | $clock->itemconfigure ("date", -font => $data->{dateFont}); 580 | } 581 | elsif ($attr eq "timeColor") { 582 | $clock->itemconfigure ("time", -fill => $data->{timeColor}); 583 | } 584 | elsif ($attr eq "timeFont") { 585 | $clock->itemconfigure ("time", -font => $data->{timeFont}); 586 | } 587 | elsif ($attr eq "time2Color") { 588 | $clock->itemconfigure ("time2",-fill => $data->{time2Color}); 589 | } 590 | elsif ($attr eq "time2Font") { 591 | $clock->itemconfigure ("time2",-font => $data->{time2Font}); 592 | } 593 | elsif ($attr eq "infoColor") { 594 | $clock->itemconfigure ("info", -fill => $data->{infoColor}); 595 | } 596 | elsif ($attr eq "infoFont") { 597 | $clock->itemconfigure ("info", -font => $data->{infoFont}); 598 | } 599 | elsif ($attr eq "textColor") { 600 | $clock->itemconfigure ("text", -fill => $data->{textColor}); 601 | } 602 | elsif ($attr eq "textFont") { 603 | $clock->itemconfigure ("text", -font => $data->{textFont}); 604 | } 605 | elsif ($attr eq "useLocale") { 606 | $locale{$data->{useLocale}} or _newLocale ($data->{useLocale}); 607 | } 608 | elsif ($attr eq "dateFormat" || $attr eq "timeFormat" || $attr eq "time2Format" || 609 | $attr eq "infoFormat" || $attr eq "textFormat") { 610 | my %fmt = ( 611 | "S" => '%d', # 45 612 | "SS" => '%02d', # 45 613 | "Sc" => '%02d', # 45 countdown 614 | "M" => '%d', # 7 615 | "MM" => '%02d', # 07 616 | "Mc" => '%02d', # 07 countdown 617 | "H" => '%d', # 6 618 | "HH" => '%02d', # 06 619 | "Hc" => '%02d', # 06 countdown 620 | "h" => '%d', # 6 AM/PM 621 | "hh" => '%02d', # 06 AM/PM 622 | "A" => '%s', # PM 623 | "d" => '%d', # 6 624 | "dd" => '%02d', # 06 625 | "ddd" => '%3s', # Mon 626 | "dddd" => '%s', # Monday 627 | "m" => '%d', # 7 628 | "mm" => '%02d', # 07 629 | "mmm" => '%3s', # Jul 630 | "mmmm" => '%s', # July 631 | "y" => '%d', # 98 632 | "yy" => '%02d', # 98 633 | "yyy" => '%04d', # 1998 634 | "yyyy" => '%04d', # 1998 635 | "w" => '%d', # 28 (week) 636 | "ww" => '%02d', # 28 637 | ); 638 | my $fmt = $data->{$attr}; 639 | $fmt =~ m{[\%\@\$]} and croak "%, \@ and \$ not allowed in $attr"; 640 | my $xfmt = join "|", reverse sort keys %fmt; 641 | my @fmt = split m/\b($xfmt)\b/, $fmt; 642 | my $args = ""; 643 | $fmt = ""; 644 | my $locale = $data->{useLocale} || "C"; 645 | foreach my $f (@fmt) { 646 | if (defined $fmt{$f}) { 647 | $fmt .= $fmt{$f}; 648 | if ($f =~ m/^m+$/) { 649 | my $l = length ($f) - 1; 650 | $args .= ", Tk::Clock::_month (q{$locale}, \$m, $l)"; 651 | } 652 | elsif ($f =~ m/^ddd+$/) { 653 | my $l = length ($f) - 3; 654 | $args .= ", Tk::Clock::_wday (q{$locale}, \$wd, $l)"; 655 | } 656 | else { 657 | $args .= ', $' . substr ($f, 0, 1); 658 | $f =~ m/^[HMS]c/ and $args .= "c"; 659 | $f =~ m/^y+$/ and 660 | $args .= length ($f) < 3 ? " % 100" : " + 1900"; 661 | } 662 | } 663 | else { 664 | $fmt .= $f; 665 | } 666 | } 667 | $data->{Clock_h} = -1; # force update; 668 | my $cb = eval join "\n" => 669 | q[ sub ], 670 | q[ { ], 671 | q[ my ($S, $M, $H, $d, $m, $y, $wd, $yd, $dst, ], 672 | q[ $Sc, $Mc, $Hc) = @_; ], 673 | q[ my $w = $yd / 7 + 1; ], 674 | q[ my $h = $H % 12; ], 675 | q[ my $A = $H > 11 ? "PM" : "AM"; ], 676 | # AM/PM users expect 12:15 AM instead of 00:15 AM 677 | q[ $h ||= 12; ], 678 | qq[ sprintf qq!$fmt!$args; ], 679 | q[ } ]; 680 | my $fmt_tag = $attr =~ m/^time2/ ? "2" : substr $attr, 0, 1; 681 | $data->{"fmt$fmt_tag"} = $cb; 682 | } 683 | elsif ($attr eq "timerValue") { 684 | $data->{timerStart} = $data->{timerValue} ? time : undef; 685 | } 686 | elsif ($attr eq "tickFreq") { 687 | # $data->{tickFreq} < 1 || 688 | # $data->{tickFreq} != int $data->{tickFreq} and 689 | # $data->{tickFreq} = $old; 690 | unless ($data->{tickFreq} == $old) { 691 | $clock->_destroyAnalog; 692 | $clock->_createAnalog; 693 | } 694 | } 695 | elsif ($attr eq "autoScale") { 696 | $autoScale = !!$data->{autoScale}; 697 | } 698 | elsif ($attr eq "anaScale") { 699 | if ($data->{anaScale} eq "auto" or $data->{anaScale} <= 0) { 700 | $data->{autoScale} = 1; 701 | $data->{anaScale} = $clock 702 | ? int (100 * $clock->cget (-height) / $ana_base) || 100 703 | : 100; 704 | $data->{_anaSize} = int ($ana_base * $data->{anaScale} / 100.); 705 | } 706 | else { 707 | defined $autoScale or $autoScale = 0; 708 | my $new_size = int ($ana_base * $data->{anaScale} / 100.); 709 | unless ($new_size == $data->{_anaSize}) { 710 | $data->{_anaSize} = $new_size; 711 | $clock->_destroyAnalog; 712 | $clock->_createAnalog; 713 | if (exists $conf->{anaScale} && $data->{useDigital}) { 714 | # Otherwise the digital either overlaps the analog 715 | # or there is a gap 716 | $clock->_destroyDigital; 717 | $clock->_createDigital; 718 | } 719 | $clock->after (5, ["_run" => $clock]); 720 | } 721 | } 722 | } 723 | elsif ($attr eq "backDrop" && $data->{useAnalog}) { 724 | $clock->delete ("back"); 725 | if (ref $data->{backDrop} eq "Tk::Photo") { 726 | $clock->createImage (0, 0, 727 | -anchor => "nw", 728 | -image => $data->{backDrop}, 729 | -tags => "back", 730 | ); 731 | $clock->lower ("back", ($clock->find ("withtag", "tick"))[0]); 732 | } 733 | } 734 | elsif ($attr eq "useAnalog") { 735 | if ($old == 1 && !$data->{useAnalog}) { 736 | $clock->_destroyAnalog; 737 | $clock->_destroyDigital; 738 | $data->{useDigital} and $clock->_createDigital; 739 | } 740 | elsif ($old == 0 && $data->{useAnalog}) { 741 | $clock->_destroyDigital; 742 | $clock->_createAnalog; 743 | $data->{useDigital} and $clock->_createDigital; 744 | } 745 | $clock->after (5, ["_run" => $clock]); 746 | } 747 | elsif ($attr eq "useInfo") { 748 | if ($old ^ $data->{useInfo} && $data->{useAnalog}) { 749 | $clock->_destroyAnalog; 750 | $clock->_destroyDigital; 751 | $clock->_createAnalog; 752 | $data->{useDigital} and $clock->_createDigital; 753 | } 754 | $clock->after (5, ["_run" => $clock]); 755 | } 756 | elsif ($attr eq "useText") { 757 | if ($old ^ $data->{useText} && $data->{useAnalog}) { 758 | $clock->_destroyAnalog; 759 | $clock->_destroyDigital; 760 | $clock->_createAnalog; 761 | $data->{useDigital} and $clock->_createDigital; 762 | } 763 | $clock->after (5, ["_run" => $clock]); 764 | } 765 | elsif ($attr eq "time2TZ") { 766 | defined $data->{time2TZ} or $data->{time2TZ} = ""; 767 | if ($old ^ $data->{time2TZ} && $data->{useAnalog}) { 768 | $data->{time2TZ} && !$data->{time2Format} and $clock->config (time2Format => "HH:MM:SS"); 769 | $clock->_destroyAnalog; 770 | $clock->_destroyDigital; 771 | $clock->_createAnalog; 772 | $data->{useDigital} and $clock->_createDigital; 773 | } 774 | $clock->after (5, ["_run" => $clock]); 775 | } 776 | elsif ($attr eq "useDigital") { 777 | if ($old == 1 && !$data->{useDigital}) { 778 | $clock->_destroyDigital; 779 | } 780 | elsif ($old == 0 && $data->{useDigital}) { 781 | $clock->_createDigital; 782 | } 783 | $clock->after (5, ["_run" => $clock]); 784 | } 785 | elsif ($attr eq "digiAlign") { 786 | if ($data->{useDigital} && $old ne $data->{digiAlign}) { 787 | $clock->_destroyDigital; 788 | $clock->_createDigital; 789 | $clock->after (5, ["_run" => $clock]); 790 | } 791 | } 792 | } 793 | _booleans ($data); 794 | if (defined $autoScale) { 795 | $data->{autoScale} = $autoScale; 796 | if ($autoScale) { 797 | $clock->Tk::bind ("Tk::Clock","<>", \&_resize_auto); 798 | $clock->parent->Tk::bind ( "<>", \&_resize_auto); 799 | $clock->_resize_auto; 800 | } 801 | else { 802 | $clock->Tk::bind ("Tk::Clock","<>", sub {}); 803 | $clock->parent->Tk::bind ( "<>", sub {}); 804 | } 805 | } 806 | $clock->_resize; 807 | $clock; 808 | } # config 809 | 810 | sub _run { 811 | my $clock = shift; 812 | 813 | my $data = $clock->privateData; 814 | 815 | $data->{timeZone} and local $ENV{TZ} = $data->{timeZone}; 816 | my $t = time + $data->{localOffset}; 817 | $t == $data->{_time_} and return; # Same time, no update 818 | $t < $data->{_time_} and # Time wound back (ntp or date command) 819 | ($data->{Clock_h}, $data->{Clock_m}, $data->{Clock_s}) = (-1, -1, -1); 820 | $data->{_time_} = $t; 821 | my @t = localtime $t; 822 | 823 | my ($Sc, $Mc, $Hc) = (0, 0, 0); 824 | if ($data->{timerValue}) { 825 | use integer; 826 | 827 | defined $data->{timerStart} or $data->{timerStart} = $t; 828 | my $tv = $data->{timerValue} - ($t - $data->{timerStart}); 829 | if ($tv < 0) { 830 | $data->{timerValue} = 0; 831 | $data->{timerStart} = undef; 832 | } 833 | else { 834 | $Sc = $tv % 60; 835 | $tv /= 60; 836 | $Mc = $tv % 60; 837 | $tv /= 60; 838 | $Hc = $tv; 839 | } 840 | } 841 | push @t, $Sc, $Mc, $Hc; 842 | 843 | unless ($t[2] == $data->{Clock_h}) { 844 | $data->{Clock_h} = $t[2]; 845 | $data->{fmtd} ||= sub { 846 | sprintf "%02d-%02d-%02d", $_[3], $_[4] + 1, $_[5] + 1900; 847 | }; 848 | $data->{useDigital} and 849 | $clock->itemconfigure ("date", -text => $data->{fmtd}->(@t)); 850 | } 851 | 852 | unless ($t[1] == $data->{Clock_m}) { 853 | $data->{Clock_m} = $t[1]; 854 | if ($data->{useAnalog}) { 855 | my ($h24, $m24) = $data->{ana24hour} ? (24, 2.5) : (12, 5); 856 | $clock->coords ("hour", 857 | $clock->_where (($data->{Clock_h} % $h24) * $m24 + $t[1] / $h24, 22, $data->{_anaSize})); 858 | 859 | $clock->coords ("min", 860 | $clock->_where ($data->{Clock_m}, 30, $data->{_anaSize})); 861 | } 862 | } 863 | 864 | $data->{Clock_s} = $t[0]; 865 | if ($data->{useAnalog}) { 866 | $data->{useSecHand} and 867 | $clock->coords ("sec", 868 | $clock->_where ($data->{Clock_s}, 34, $data->{_anaSize})); 869 | $data->{fmti} ||= sub { sprintf "%02d:%02d:%02d", @_[2,1,0]; }; 870 | $data->{useInfo} ? $clock->itemconfigure ("info", -text => $data->{fmti}->(@t)) : $clock->delete ("info"); 871 | $data->{useText} ? $clock->itemconfigure ("text", -text => _timeText ($data, "text")) : $clock->delete ("text"); 872 | $data->{time2TZ} ? $clock->itemconfigure ("time2", -text => _timeText ($data, "time2")) : $clock->delete ("time2"); 873 | } 874 | $data->{fmtt} ||= sub { sprintf "%02d:%02d:%02d", @_[2,1,0]; }; 875 | $data->{useDigital} and $clock->itemconfigure ("time", -text => $data->{fmtt}->(@t)); 876 | 877 | $data->{autoScale} and $clock->_resize_auto; 878 | } # _run 879 | 880 | 1; 881 | 882 | __END__ 883 | 884 | =head1 NAME 885 | 886 | Tk::Clock - Clock widget with analog and digital display 887 | 888 | =head1 SYNOPSIS 889 | 890 | use Tk; 891 | use Tk::Clock; 892 | 893 | $clock = $parent->Clock (?-option => ...?); 894 | 895 | $clock->config ( # These reflect the defaults 896 | timeZone => "", 897 | useLocale => "C", 898 | backDrop => "", 899 | 900 | useAnalog => 1, 901 | handColor => "Green4", 902 | secsColor => "Green2", 903 | tickColor => "Yellow4", 904 | tickFreq => 1, 905 | tickDiff => 0, 906 | useSecHand => 1, 907 | handCenter => 0, 908 | anaScale => 100, 909 | autoScale => 0, 910 | ana24hour => 0, 911 | countDown => 0, 912 | timerValue => 0, 913 | localOffset => 0, 914 | 915 | useInfo => 0, 916 | infoColor => "#cfb53b", 917 | infoFormat => "HH:MM:SS", 918 | infoFont => "fixed 6", 919 | useText => 0, 920 | textColor => "#c4c4c4", 921 | textFormat => "HH:MM:SS", 922 | textFont => "fixed 6", 923 | time2Font => "fixed 6", 924 | time2Color => "Red4", 925 | time2Format => "HH:MM:SS", 926 | time2TZ => "Europe/Amsterdam", 927 | 928 | useDigital => 1, 929 | digiAlign => "center", 930 | timeFont => "fixed 6", 931 | timeColor => "Red4", 932 | timeFormat => "HH:MM:SS", 933 | dateFont => "fixed 6", 934 | dateColor => "Blue4", 935 | dateFormat => "dd-mm-yy", 936 | ); 937 | 938 | =head1 DESCRIPTION 939 | 940 | This module implements a Canvas-based clock widget for perl-Tk with lots 941 | of options to change the appearance. 942 | 943 | Both analog and digital clocks are implemented. 944 | 945 | =head1 METHODS 946 | 947 | =head2 Clock 948 | 949 | This is the constructor. It does accept the standard widget options plus those 950 | described in L. 951 | 952 | =head2 config 953 | 954 | Below is a description of the options/attributes currently available. Their 955 | default value is in between parenthesis. 956 | 957 | =over 4 958 | 959 | =item useAnalog (1) 960 | 961 | =item useInfo (0) 962 | 963 | =item useText (0) 964 | 965 | =item useDigital (1) 966 | 967 | Enable the analog clock (C) and/or the digital clock (C) 968 | in the widget. The analog clock will always be displayed above the digital part 969 | 970 | +----------+ ...... 971 | | .. | \ . \ | . 972 | | . \_ . | |_ Analog clock . Tim2 . 973 | | . . | | . * . 974 | | .. | / . Info . 975 | | 23:59:59 | --- Digital time . Text . 976 | | 31-12-09 | --- Digital date ...... 977 | +----------+ 978 | 979 | The analog clock displays ticks, hour hand, minutes hand and second hand. 980 | The digital part displays two parts, which are configurable. By default 981 | these are time and date. 982 | 983 | The C enables a text field between the backdrop of the analog 984 | clock and its items. You can use this field to display personal data. 985 | 986 | The C is like second line of C, but with support for 987 | callbacks or variable binding. 988 | 989 | $clock->configure (useText => 1, textFormat => \$foo); 990 | $clock->configure (useText => 1, textFormat => sub { int rand 42 }); 991 | 992 | =item autoScale (0) 993 | 994 | When set to a true value, the widget will try to re-scale itself to 995 | automatically fit the containing widget. 996 | 997 | $clock->config (autoScale => 1); 998 | 999 | =item anaScale (100) 1000 | 1001 | The analog clock can be enlarged or reduced using anaScale for which 1002 | the default of 100% is about 72x72 pixels. 1003 | 1004 | When using C for your geometry management, be sure to pass 1005 | C<-expand => 1, -fill => "both"> if you plan to resize with 1006 | C or enable/disable either analog or digital after the 1007 | clock was displayed. 1008 | 1009 | $clock->config (anaScale => 400); 1010 | 1011 | =item ana24hour (0) 1012 | 1013 | The default for the analog clock it the normal 12 hours display, as 1014 | most clocks are. This option will show a clock where one round of the 1015 | hour-hand will cover a full day of 24 hours, noon is at the bottom 1016 | where the 6 will normally display. 1017 | 1018 | $clock->config (ana24hour => 1); 1019 | 1020 | =item useSecHand (1) 1021 | 1022 | This controls weather the seconds-hand is shown. 1023 | 1024 | $clock->config (useSecHand => 0); 1025 | 1026 | =item countDown (0) 1027 | 1028 | When C is set to a true value, the clock will run backwards. 1029 | This is a slightly experimental feature, it will not count down to a 1030 | specific point in time, but will simply reverse the rotation, making 1031 | the analog clock run counterclockwise. 1032 | 1033 | =item timerValue (0) 1034 | 1035 | This represents a countdown timer. 1036 | 1037 | When setting C to a number of seconds, the format values 1038 | C, C, and C will represent the hour, minute and second of 1039 | the this value. When the time reaches 0, all countdown values are 1040 | reset to 0. 1041 | 1042 | =item localOffset (0) 1043 | 1044 | The value of this attribute represents the local offset for this clock 1045 | in seconds. Negative is back in time, positive is in the future. 1046 | 1047 | # Wind back clock 4 days, 5 hours, 6 minutes and 7 seconds 1048 | $clock->config (localOffset => -363967); 1049 | 1050 | =item handColor ("Green4") 1051 | 1052 | =item secsColor ("Green2") 1053 | 1054 | Set the color of the hands of the analog clock. C controls 1055 | the color for both the hour-hand and the minute-hand. C 1056 | controls the color for the seconds-hand. 1057 | 1058 | $clock->config ( 1059 | handColor => "#7F0000", 1060 | secsColor => "OrangeRed", 1061 | ); 1062 | 1063 | =item handCenter (0) 1064 | 1065 | If set to a true value, will display a circular extension in the center 1066 | of the analog clock that extends the hands as if they have a wider area 1067 | at their turning point, like many station-type clocks (at least in the 1068 | Netherlands) have. 1069 | 1070 | $clock->config (handCenter => 1); 1071 | 1072 | =item tickColor ("Yellow4") 1073 | 1074 | Controls the color of the ticks in the analog clock. 1075 | 1076 | $clock->config (tickColor => "White"); 1077 | 1078 | =item tickFreq (1) 1079 | 1080 | =item tickDiff (0) 1081 | 1082 | C controls how many ticks are shown in the analog clock. 1083 | 1084 | Meaningful values for C are 1, 5 and 15 showing all ticks, tick 1085 | every 5 minutes or the four main ticks only, though any positive integer 1086 | will do (put a tick on any C minute). 1087 | 1088 | When setting tickDiff to a true value, the major ticks will use a thicker 1089 | line than the minor ticks. 1090 | 1091 | $clock->config ( 1092 | tickFreq => 5, 1093 | tickDiff => 1, 1094 | ); 1095 | 1096 | =item timeZone ("") 1097 | 1098 | Set the timezone for the widget. The format should be the format recognized 1099 | by the system. If unset, the local timezone is used. 1100 | 1101 | $clock->config (timeZone => "Europe/Amsterdam"); 1102 | $clock->config (timeZone => "MET-1METDST"); 1103 | 1104 | =item useLocale ("C") 1105 | 1106 | Use this locale for the text shown in month formats C and C and in 1107 | day formats C and C. 1108 | 1109 | $clock->config (useLocale => $ENV{LC_TIME} // $ENV{LC_ALL} 1110 | // $ENV{LANG} // "nl_NL.utf8"); 1111 | 1112 | See L for a table of locales 1113 | and the Windows equivalents. Windows might not have a UTF8 version available 1114 | of the required locale. 1115 | 1116 | =item timeFont ("fixed 6") 1117 | 1118 | Controls the font to be used for the top line in the digital clock. Will 1119 | accept all fonts that are supported in your version of perl/Tk. This includes 1120 | both True Type and X11 notation. 1121 | 1122 | $clock->config (timeFont => "{Liberation Mono} 11"); 1123 | 1124 | =item timeColor ("Red4") 1125 | 1126 | Controls the color of the first line (time) of the digital clock. 1127 | 1128 | $clock->config (timeColor => "#00ff00"); 1129 | 1130 | =item timeFormat ("HH:MM:SS") 1131 | 1132 | Defines the format of the first line of the digital clock. By default it 1133 | will display the time in a 24-hour notation. 1134 | 1135 | Legal C characters are C and C for 24-hour, C and 1136 | C for AM/PM hour, C and C for minutes, C and C for 1137 | seconds, C for countdown/timer hour, C for countdown/timer 1138 | minutes, C for countdown/timer seconds, C for AM/PM indicator, 1139 | C and C
for day-of-the month, C and C for short and 1140 | long weekday, C, C, C and C for month, C and C 1141 | for year, C and C for week-number and any separators C<:>, C<->, 1142 | C or C. 1143 | 1144 | $clock->config (timeFormat => "hh:MM A"); 1145 | 1146 | The text shown in the formats C, C, C, and C might be 1147 | influenced by the setting of C. The fallback is locale "C". 1148 | 1149 | =item time2Font ("fixed 6") 1150 | 1151 | Controls the font to be used for the alternate time in the analog clock. Will 1152 | accept all fonts that are supported in your version of perl/Tk. This includes 1153 | both True Type and X11 notation. 1154 | 1155 | $clock->config (time2Font => "{Liberation Mono} 11"); 1156 | 1157 | =item time2Color ("Gray30") 1158 | 1159 | Controls the color of the alternate time line of the analog clock. 1160 | 1161 | $clock->config (time2Color => "#00ff00"); 1162 | 1163 | =item time2Format ("HH:MM:SS") 1164 | 1165 | Defines the format of the alternate time line of the analog clock. By 1166 | default it will display the time in a 24-hour notation. 1167 | 1168 | The supported format is the same as for C. 1169 | 1170 | =item time2TZ ("Europe/Amsterdam") 1171 | 1172 | Define the time zone for the alternate time in the analog clock. When 1173 | empty, it disables the display of an alternate time. 1174 | 1175 | $clock->config (time2TZ => ""); 1176 | $clock->config (time2TZ => "UTC"); 1177 | 1178 | =item dateFont ("fixed 6") 1179 | 1180 | Controls the font to be used for the bottom line in the digital clock. Will 1181 | accept all fonts that are supported in your version of perl/Tk. This includes 1182 | both True Type and X11 notation. 1183 | 1184 | $clock->config (dateFont => "-misc-fixed-*-normal--15-*-c-iso8859-1"); 1185 | 1186 | =item dateColor ("Blue4") 1187 | 1188 | Controls the color of the second line (date) of the digital clock. 1189 | 1190 | $clock->config (dateColor => "Navy"); 1191 | 1192 | =item dateFormat ("dd-mm-yy") 1193 | 1194 | Defines the format of the second line of the digital clock. By default it 1195 | will display the date in three groups of two digits representing the day of 1196 | the month, the month, and the last two digits of the year, separated by dashes. 1197 | 1198 | $clock->config (dateFormat => "ww dd-mm"); 1199 | 1200 | The supported format is the same as for C. 1201 | 1202 | =item infoFont ("fixed 6") 1203 | 1204 | Controls the font to be used for the info label in the analog clock. Will 1205 | accept all fonts that are supported in your version of perl/Tk. This includes 1206 | both True Type and X11 notation. 1207 | 1208 | $clock->config (infoFont => "{DejaVu Sans Mono} 8"); 1209 | 1210 | =item infoColor ("#cfb53b") 1211 | 1212 | Controls the color of the info label of the analog clock (default is a 1213 | shade of Gold). 1214 | 1215 | $clock->config (infoColor => "Yellow"); 1216 | 1217 | =item infoFormat ("HH:MM:SS") 1218 | 1219 | Defines the format of the label inside the analog clock. By default will not 1220 | be displayed. Just as C and C the content is updated 1221 | every second if enabled. 1222 | 1223 | $clock->config (infoFormat => "BREITLING"); 1224 | 1225 | The supported format is the same as for C. 1226 | 1227 | =item digiAlign ("center") 1228 | 1229 | Controls the placement of the text in the digital clock. The only legal values 1230 | for C are "left", "center", and "right". 1231 | Any other value will be interpreted as the default "center". 1232 | 1233 | $clock->config (digiAlign => "right"); 1234 | 1235 | =item backDrop ("") 1236 | 1237 | By default the background of the clock is controlled by the C<-background> 1238 | attribute to the constructor, which may default to the default background 1239 | used in the perl/Tk script. 1240 | 1241 | The C attribute accepts any valid Tk::Photo object, and it will 1242 | show (part of) the image as a backdrop of the clock 1243 | 1244 | use Tk; 1245 | use Tk::Clock; 1246 | use Tk::Photo; 1247 | use Tk::PNG; 1248 | 1249 | my $mainw = MainWindow->new; 1250 | my $backd = $mainw->Photo ( 1251 | -file => "image.png", 1252 | ); 1253 | my $clock = $mainw->Clock ( 1254 | -relief => "flat", 1255 | )->pack (-expand => 1, -fill => "both"); 1256 | $clock->config ( 1257 | backDrop => $backd, 1258 | ); 1259 | MainLoop; 1260 | 1261 | =back 1262 | 1263 | The C constructor will also accept options valid for Canvas widgets, 1264 | like C<-background> and C<-relief>. 1265 | 1266 | =head1 TAGS 1267 | 1268 | As all of the clock is part of a Canvas, the items cannot be addressed as 1269 | Subwidgets. You can however alter presentation afterwards using the tags: 1270 | 1271 | my $clock = $mw->Clock->pack; 1272 | $clock->itemconfigure ("date", -fill => "Red"); 1273 | 1274 | Currently defined tags are C, C, C, C, C, 1275 | C, and C