Tk-Clock
view release on metacpan or search on metacpan
return $l;
} # _newLocale
sub _month { # (month, size)
my ($locale, $m, $l) = @_;
($locale{$locale} || $locale{C})->{month}[$m][$l];
} # _month
sub _wday { # (wday, size)
my ($locale, $m, $l) = @_;
($locale{$locale} || $locale{C})->{day}[$m][$l];
} # _wday
sub _min {
$_[0] <= $_[1] ? $_[0] : $_[1];
} # _min
sub _max {
$_[0] >= $_[1] ? $_[0] : $_[1];
} # _max
# Transparent packInfo for pack/grid/place/form
sub _packinfo {
my $clock = shift;
my %pi = map { ("-$_" => 0) } qw( padx pady ipadx ipady );
if (my $pm = $clock->manager) {
if ($pm eq "pack") {
%pi = $clock->packInfo;
}
elsif ($pm eq "grid") {
%pi = $clock->gridInfo;
}
elsif ($pm eq "form") {
%pi = $clock->formInfo;
# padx pady padleft padright padtop padbottom
$pi{"-ipadx"} = int (((delete $pi{"-padleft"}) + (delete $pi{"-padright"} )) / 2);
$pi{"-ipady"} = int (((delete $pi{"-padtop"} ) + (delete $pi{"-padbottom"})) / 2);
}
elsif ($pm eq "place") {
# No action, place has no padding
}
else {
# No action, unknown geometry manager
}
}
%pi;
} # _packinfo
sub _resize {
my $clock = shift;
use integer;
my $data = $clock->privateData;
my $hght = $data->{useAnalog} * $data->{_anaSize} +
$data->{useDigital} * $data->{_digSize} + 1;
my $wdth = _max ($data->{useAnalog} * $data->{_anaSize},
$data->{useDigital} * $data->{_digWdth});
my $dim = "${wdth}x${hght}";
my $geo = $clock->parent->geometry;
my ($pw, $ph) = split m/\D/, $geo; # Cannot use ->cget here
if ($ph > 5 && $clock->parent->isa ("MainWindow")) {
my %pi = $clock->_packinfo;
my $px = _max ($wdth + $pi{"-padx"}, $pw);
my $py = _max ($hght + $pi{"-pady"}, $ph);
$clock->parent->geometry ("${px}x$py");
}
$clock->configure (
-height => $hght,
-width => $wdth);
$dim;
} # _resize
# Callback when auto-resize is called
sub _resize_auto {
my $clock = shift;
my $data = $clock->privateData;
$data->{useAnalog} && $data->{autoScale} == 1 or return;
my $owdth = $data->{useAnalog} * $data->{_anaSize};
my $geo = $clock->geometry;
my ($gw, $gh) = split m/\D/, $geo; # Cannot use ->cget here
$gw < 5 and return; # not packed yet?
$data->{useDigital} and $gh -= $data->{_digSize};
my $nwdth = _min ($gw, $gh - 1);
abs ($nwdth - $owdth) > 5 && $nwdth >= 10 or return;
$data->{_anaSize} = $nwdth - 2;
$clock->_destroyAnalog;
$clock->_createAnalog;
if ($data->{useDigital}) {
# Otherwise the digital either overlaps the analog
# or there is a gap
$clock->_destroyDigital;
$clock->_createDigital;
}
$clock->_resize;
} # _resize_auto
sub _createDigital {
my $clock = shift;
my $data = $clock->privateData;
# Dynamically determine the size of the digital display
my @t = localtime (time + $data->{localOffset});
my ($wd, $hd) = do {
my $s_date = $data->{fmtd}->(@t, 0, 0, 0);
$s_date =~ s/\b([0-9])\b/0$1/g; # prepare "d" running from 9 to 10
my $f = $clock->Label (-font => $data->{dateFont})->cget (-font);
my %fm = $clock->fontMetrics ($f);
($clock->fontMeasure ($f, $s_date), $fm{"-linespace"} || 9);
};
my ($wt, $ht) = do {
my $s_time = $data->{fmtt}->(@t, 0, 0, 0);
$s_time =~ s/\b([0-9])\b/0$1/g; # prepare "h" running from 9 to 10
my $f = $clock->Label (-font => $data->{timeFont})->cget (-font);
my %fm = $clock->fontMetrics ($f);
($clock->fontMeasure ($f, $s_time), $fm{"-linespace"} || 9);
};
my $w = _max (72, int (1.1 * _max ($wt, $wd)));
$data->{_digSize} = $hd + 4 + $ht + 4; # height of date + time
$data->{_digWdth} = $w;
my $wdth = _max ($data->{useAnalog} * $data->{_anaSize},
$data->{useDigital} * $w);
my ($pad, $anchor) = (5, "s");
my ($x, $y) = ($wdth / 2, $data->{useAnalog} * $data->{_anaSize});
if ($data->{digiAlign} eq "left") {
($anchor, $x) = ("sw", $pad);
}
elsif ($data->{digiAlign} eq "right") {
($anchor, $x) = ("se", $wdth - $pad);
}
$clock->createText ($x, $y + $ht + 4 + $hd,
-anchor => $anchor,
-width => ($wdth - 2 * $pad),
-font => $data->{dateFont},
-fill => $data->{dateColor},
-text => $data->{dateFormat},
-tags => "date");
$clock->createText ($x, $y + $ht + 2,
elsif ($attr eq "timeColor") {
$clock->itemconfigure ("time", -fill => $data->{timeColor});
}
elsif ($attr eq "timeFont") {
$clock->itemconfigure ("time", -font => $data->{timeFont});
}
elsif ($attr eq "time2Color") {
$clock->itemconfigure ("time2",-fill => $data->{time2Color});
}
elsif ($attr eq "time2Font") {
$clock->itemconfigure ("time2",-font => $data->{time2Font});
}
elsif ($attr eq "infoColor") {
$clock->itemconfigure ("info", -fill => $data->{infoColor});
}
elsif ($attr eq "infoFont") {
$clock->itemconfigure ("info", -font => $data->{infoFont});
}
elsif ($attr eq "textColor") {
$clock->itemconfigure ("text", -fill => $data->{textColor});
}
elsif ($attr eq "textFont") {
$clock->itemconfigure ("text", -font => $data->{textFont});
}
elsif ($attr eq "useLocale") {
$locale{$data->{useLocale}} or _newLocale ($data->{useLocale});
}
elsif ($attr eq "dateFormat" || $attr eq "timeFormat" || $attr eq "time2Format" ||
$attr eq "infoFormat" || $attr eq "textFormat") {
my %fmt = (
"S" => '%d', # 45
"SS" => '%02d', # 45
"Sc" => '%02d', # 45 countdown
"M" => '%d', # 7
"MM" => '%02d', # 07
"Mc" => '%02d', # 07 countdown
"H" => '%d', # 6
"HH" => '%02d', # 06
"Hc" => '%02d', # 06 countdown
"h" => '%d', # 6 AM/PM
"hh" => '%02d', # 06 AM/PM
"A" => '%s', # PM
"d" => '%d', # 6
"dd" => '%02d', # 06
"ddd" => '%3s', # Mon
"dddd" => '%s', # Monday
"m" => '%d', # 7
"mm" => '%02d', # 07
"mmm" => '%3s', # Jul
"mmmm" => '%s', # July
"y" => '%d', # 98
"yy" => '%02d', # 98
"yyy" => '%04d', # 1998
"yyyy" => '%04d', # 1998
"w" => '%d', # 28 (week)
"ww" => '%02d', # 28
);
my $fmt = $data->{$attr};
$fmt =~ m{[\%\@\$]} and croak "%, \@ and \$ not allowed in $attr";
my $xfmt = join "|", reverse sort keys %fmt;
my @fmt = split m/\b($xfmt)\b/, $fmt;
my $args = "";
$fmt = "";
my $locale = $data->{useLocale} || "C";
foreach my $f (@fmt) {
if (defined $fmt{$f}) {
$fmt .= $fmt{$f};
if ($f =~ m/^m+$/) {
my $l = length ($f) - 1;
$args .= ", Tk::Clock::_month (q{$locale}, \$m, $l)";
}
elsif ($f =~ m/^ddd+$/) {
my $l = length ($f) - 3;
$args .= ", Tk::Clock::_wday (q{$locale}, \$wd, $l)";
}
else {
$args .= ', $' . substr ($f, 0, 1);
$f =~ m/^[HMS]c/ and $args .= "c";
$f =~ m/^y+$/ and
$args .= length ($f) < 3 ? " % 100" : " + 1900";
}
}
else {
$fmt .= $f;
}
}
$data->{Clock_h} = -1; # force update;
my $cb = eval join "\n" =>
q[ sub ],
q[ { ],
q[ my ($S, $M, $H, $d, $m, $y, $wd, $yd, $dst, ],
q[ $Sc, $Mc, $Hc) = @_; ],
q[ my $w = $yd / 7 + 1; ],
q[ my $h = $H % 12; ],
q[ my $A = $H > 11 ? "PM" : "AM"; ],
# AM/PM users expect 12:15 AM instead of 00:15 AM
q[ $h ||= 12; ],
qq[ sprintf qq!$fmt!$args; ],
q[ } ];
my $fmt_tag = $attr =~ m/^time2/ ? "2" : substr $attr, 0, 1;
$data->{"fmt$fmt_tag"} = $cb;
}
elsif ($attr eq "timerValue") {
$data->{timerStart} = $data->{timerValue} ? time : undef;
}
elsif ($attr eq "tickFreq") {
# $data->{tickFreq} < 1 ||
# $data->{tickFreq} != int $data->{tickFreq} and
# $data->{tickFreq} = $old;
unless ($data->{tickFreq} == $old) {
$clock->_destroyAnalog;
$clock->_createAnalog;
}
}
elsif ($attr eq "autoScale") {
$autoScale = !!$data->{autoScale};
}
elsif ($attr eq "anaScale") {
if ($data->{anaScale} eq "auto" or $data->{anaScale} <= 0) {
$data->{autoScale} = 1;
$data->{anaScale} = $clock
( run in 2.682 seconds using v1.01-cache-2.11-cpan-71847e10f99 )