=head1 NAME

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

=head1 SYNOPSIS

use Tk
use Tk::Clock;

$clock = $parent->Clock (?-option => <value> ...?);

$clock->config (	# These reflect the defaults
    useDigital	=> 1,
    useAnalog	=> 1,
    anaScale	=> 100,
    handColor	=> "Green4",
    secsColor	=> "Green2",
    tickColor	=> "Yellow4",
    tickFreq	=> 1,
    timeFont	=> "fixed",
    timeColor	=> "Red4",
    timeFormat	=> "HH.MM:SS",
    dateFont	=> "fixed",
    dateColor	=> "Blue4",
    dateFormat	=> "dd-mm-yy");

=head1 DESCRIPTION

Create a clock canvas with both an analog- and a digital display. Either
can be disabled by setting useAnalog or useDigital to 0 resp.

Legal dateFormat characters are d and dd for date, ddd and dddd for weekday,
m, mm, mmm and mmmm for month, y and yy for year, w and ww for weeknumber and
any separators :, -, / or space.

Legal timeFormat characters are H and HH for hour, h and hh for AM/PM hour,
M and MM for minutes, S and SS for seconds, A for AM/PM indicator, d and dd
for day-of-the week in two or three characters resp. and any separators :,
-, . or space.

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).

The analog clock can be enlaged or reduced using anaScale for which the
default of 100% is about 72x72 pixels. Future enhancement will include
auto sizing for anaScale 0.

=head1 BUGS

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

Due to the fact that the year is expressed in 2 digit's, this
widget is not Y2K compliant in the default configuration.

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

=head1 TODO

* Using POSIX' strftime () for dateFormat. Current implementation
  would probably make this very slow.
* Auto sizing to fit (analog) clock in given space.

=head1 AUTHOR

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

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.

=cut

package Tk::Clock;

use Carp;
use strict;
use vars qw/$VERSION @ISA/;

use Tk::Widget;
use Tk::Derived;
use Tk::Canvas;

@ISA = qw/Tk::Derived Tk::Canvas/;
$VERSION = "0.07";

Construct Tk::Widget "Clock";

my $ana_base = 73;	# Size base for 100%
my $ana_size = 73;	# Default size
my $dig_size = 26;

my %def_config = (
    handColor	=> "Green4",
    secsColor	=> "Green2",
    tickColor	=> "Yellow4",

    timeFont	=> "fixed",
    timeColor	=> "Red4",
    timeFormat	=> "HH.MM:SS",

    dateFont	=> "fixed",
    dateColor	=> "Blue4",
    dateFormat	=> "dd-mm-yy",

    useDigital	=> 1,
    useAnalog	=> 1,
    anaScale	=> 100,
    tickFreq	=> 1,

    fmtd	=> sub {
	my ($d, $m, $y, $w) = @_;
	sprintf "%02d-%02d-%02d", $d, $m + 1, $y % 100;
	},
    fmtt	=> sub {
	my ($h, $m, $s) = @_;
	sprintf "%02d.%02d:%02d", $h, $m, $s;
	},
    );

sub month ($$)
{
    [[  "1", "01", "Jan", "January"	],
     [  "2", "02", "Feb", "February"	],
     [  "3", "03", "Mar", "March"	],
     [  "4", "04", "Apr", "April"	],
     [  "5", "05", "May", "May"		],
     [  "6", "06", "Jun", "June"	],
     [  "7", "07", "Jul", "July"	],
     [  "8", "08", "Aug", "August"	],
     [  "9", "09", "Sep", "September"	],
     [ "10", "10", "Oct", "October"	],
     [ "11", "11", "Nov", "November"	],
     [ "12", "12", "Dec", "December"	]]->[$_[0]][$_[1]];
    } # month

sub wday ($$)
{
    [[ "Sun", "Sunday"		],
     [ "Mon", "Monday"		],
     [ "Tue", "Tuesday"		],
     [ "Wed", "Wednesday"	],
     [ "Thu", "Thursday"	],
     [ "Fri", "Friday"		],
     [ "Sat", "Saturday"	]]->[$_[0]][$_[1]];
    } # wday

sub max ($$)
{
    $_[0] >= $_[1] ? $_[0] : $_[1];
    } # max

sub auto_size ()
{
    $ana_size > 0 and return $ana_size;
    } # auto_size

sub resize ($)
{
    my $clock = shift;

    my $data = $clock->privateData;
    my $hght = $data->{useAnalog}  * $ana_size + $data->{useDigital} * $dig_size + 1;
    my $wdth = max ($data->{useAnalog} * $ana_size, $data->{useDigital} * 72);
    $clock->cget (-height) == $hght &&
     $clock->cget (-width) == $wdth and return;
    $clock->configure (
	-height => $hght,
	-width  => $wdth);
    } # resize

sub createDigital ($)
{
    my $clock = shift;

    my $data = $clock->privateData;
    my $off = $data->{useAnalog} * $ana_size;
    $clock->createText (37, $off + $dig_size,
	-width  => 65,
	-font   => $data->{dateFont},
	-fill   => $data->{dateColor},
	-text   => $data->{dateFormat},
	-tags   => "date",
	-anchor => "s");
    $clock->createText (37, $off + 13,
	-width  => 65,
	-font   => $data->{timeFont},
	-fill   => $data->{timeColor},
	-text   => $data->{timeFormat},
	-tags   => "time",
	-anchor => "s");
    $data->{Clock_h} = -1;
#   $data->{Clock_m} = -1;
    $data->{Clock_s} = -1;
    $clock->resize ($data);
    } # createDigital

sub destroyDigital ($)
{
    my $clock = shift;

    $clock->delete ("date");
    $clock->delete ("time");
    } # destroyDigital

sub createAnalog ($)
{
    my $clock = shift;

    my $data = $clock->privateData;

    my $h = ($ana_size + 1) / 2 - 1;
    my $f = $data->{tickFreq};
    foreach my $tick (0 .. 59) {
	$tick % $f and next;
	my $l = $tick % 15 == 0 ? $h / 5 :
		$tick %  5 == 0 ? $h / 8 :
				  $h / 16;
	my $a = $tick * .104720;
	my $x = sin $a;
	my $y = cos $a;
	$clock->createLine (
	    ($h - $l) * $x + $h + 1, ($h - $l) * $y + $h + 1,
	     $h       * $x + $h + 1,  $h       * $y + $h + 1,
	    -tags  => "tick",
	    -arrow => "none",
	    -fill  => $data->{tickColor},
	    -width => 1.0);
	}
    $data->{Clock_h} = -1;
    $data->{Clock_m} = -1;
    $data->{Clock_s} = -1;
    $clock->resize ($data);
    } # createAnalog

sub destroyAnalog ($)
{
    my $clock = shift;

    $clock->delete ("tick");
    $clock->delete ("hour");
    $clock->delete ("min");
    $clock->delete ("sec");
    } # destroyAnalog

sub Populate
{
    my ($clock, $args) = @_;

    my $data = $clock->privateData;
    %$data = %def_config;
    $data->{Clock_h} = -1;
    $data->{Clock_m} = -1;
    $data->{Clock_s} = -1;

    $clock->SUPER::Populate ($args);

    $clock->ConfigSpecs (
        -width              => [ qw(SELF width              Width              72    ) ],
        -height             => [ qw(SELF height             Height             100   ) ],
        -relief             => [ qw(SELF relief             Relief             raised) ],
        -borderwidth        => [ qw(SELF borderWidth        BorderWidth        1     ) ],
        -highlightthickness => [ qw(SELF highlightThickness HighlightThickness 0     ) ],
        -takefocus          => [ qw(SELF takefocus          Takefocus          0     ) ],
        );

    $data->{useDigital} and $clock->createDigital;
    $data->{useAnalog}  and $clock->createAnalog;
	
    $clock->repeat (995, ["run" => $clock]);
    } # Populate

sub config ($@)
{
    my $clock = shift;

    ref $clock or croak "Bad method call";
    @_ or return;

    my $conf;
    if (ref $_[0] eq "HASH") {
	$conf = shift;
	}
    elsif (scalar @_ % 2 == 0) {
	my %conf = @_;
	$conf = \%conf;
	}
    else {
	croak "Bad hash";
	}

    my $data = $clock->privateData;
    foreach my $conf_spec (keys %def_config) {
	defined $conf->{$conf_spec} or next;
	defined $data->{$conf_spec} or next;
	my $old = $data->{$conf_spec};
	$data->{$conf_spec} = $conf->{$conf_spec};
	if    ($conf_spec eq "tickColor") {
	    $clock->itemconfigure ("tick", -fill => $data->{tickColor});
	    }
	elsif ($conf_spec eq "handColor") {
	    $clock->itemconfigure ("hour", -fill => $data->{handColor});
	    $clock->itemconfigure ("min",  -fill => $data->{handColor});
	    }
	elsif ($conf_spec eq "dateColor") {
	    $clock->itemconfigure ("date", -fill => $data->{dateColor});
	    }
	elsif ($conf_spec eq "dateFont") {
	    $clock->itemconfigure ("date", -font => $data->{dateFont});
	    }
	elsif ($conf_spec eq "timeColor") {
	    $clock->itemconfigure ("time", -fill => $data->{timeColor});
	    }
	elsif ($conf_spec eq "timeFont") {
	    $clock->itemconfigure ("time", -font => $data->{timeFont});
	    }
	elsif ($conf_spec eq "dateFormat") {
	    my %fmt = (
		"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
		"w"	=> '%d',	# 28 (week)
		"ww"	=> '%02d',	# 28
		);
	    my $fmt = $data->{dateFormat};
	    $fmt =~ m(^[-dmyw/: \n]*$) or croak "Bad dateFormat";
	    my @fmt = split m/([^dmyw]+)/, $fmt;
	    my $args = "";
	    $fmt = "";
	    foreach my $f (@fmt) {
		if (defined $fmt{$f}) {
		    $fmt .= $fmt{$f};
		    if ($f =~ m/^m+$/) {
			my $l = length ($f) - 1;
			$args .= ", Tk::Clock::month (\$m, $l)";
			}
		    elsif ($f =~ m/^ddd+/) {
			my $l = length ($f) - 3;
			$args .= ", Tk::Clock::wday (\$wd, $l)";
			}
		    else {
			$args .= ', $' . substr ($f, 0, 1);
			$f =~ m/^y+$/ and
			    $args .= length ($f) < 3 ? " % 100" : " + 1900";
			}
		    }
		else {
		    $fmt .= $f;
		    }
		}
	    $data->{Clock_h} = -1;	# force update;
	    $data->{fmtd} = eval "
		sub
		{
		    my (\$d, \$m, \$y, \$wd, \$w) = \@_;
		    \$w = \$w / 7 + 1;
		    sprintf qq!$fmt!$args;
		    }";
	    }
	elsif ($conf_spec eq "timeFormat") {
	    my %fmt = (
		"H"	=> '%d',	# 6
		"HH"	=> '%02d',	# 06
		"h"	=> '%d',	# 6	AM/PM
		"hh"	=> '%02d',	# 06	AM/PM
		"M"	=> '%d',	# 7
		"MM"	=> '%02d',	# 07
		"S"	=> '%d',	# 45
		"SS"	=> '%02d',	# 45
		"A"	=> '%s',	# PM
		"dd"	=> '%.2s',	# Mo
		"ddd"	=> '%.3s',	# Mon
		);
	    my $fmt = $data->{timeFormat};
	    $fmt =~ m(^[-AhHMSd\.: ]*$) or croak "Bad timeFormat";
	    my @fmt = split m/([^AhHMSd]+)/, $fmt;
	    my $arg = "";
	    $fmt = "";
	    foreach my $f (@fmt) {
		if ($f =~ m/^dd?$/) {
		    $fmt .= $fmt{$f};
		    $arg .= ", Tk::Clock::wday (\$d, 0)";
		    }
		elsif (defined $fmt{$f}) {
		    $fmt .= $fmt{$f};
		    $arg .= ', $' . substr ($f, 0, 1);
		    }
		else {
		    $fmt .= $f;
		    }
		}
	    $data->{fmtt} = eval "
		sub
		{
		    my (\$H, \$M, \$S, \$d) = \@_;
		    my \$h = \$H % 12;
		    my \$A = \$H > 11 ? 'PM' : 'AM';
		    sprintf qq!$fmt!$arg;
		    }";
	    }
	elsif ($conf_spec eq "tickFreq") {
	    $data->{tickFreq} < 1 ||
	    $data->{tickFreq} != int $data->{tickFreq} and
		$data->{tickFreq} = $old;
	    unless ($data->{tickFreq} == $old) {
		$clock->destroyAnalog;
		$clock->createAnalog;
		}
	    }
	elsif ($conf_spec eq "anaScale") {
	    $data->{anaScale} <= 0 and	# 0 will be auto some time
		$data->{anaScale} = $old;
	    my $new_size = $ana_base * $data->{anaScale} / 100.;
	    unless ($new_size == $ana_size) {
		$ana_size = $new_size;
		$clock->destroyAnalog;
		$clock->createAnalog;
		$clock->resize;
		$clock->after (5, ["run" => $clock]);
		}
	    }
	elsif ($conf_spec eq "useAnalog") {
	    if    ($old == 1 && $data->{useAnalog} == 0) {
		$clock->destroyAnalog;
		$clock->destroyDigital;
		$data->{useDigital} and $clock->createDigital;
		}
	    elsif ($old == 0 && $data->{useAnalog} == 1) {
		$clock->destroyDigital;
		$clock->createAnalog;
		$data->{useDigital} and $clock->createDigital;
		}
	    $clock->resize;
	    $clock->after (5, ["run" => $clock]);
	    }
	elsif ($conf_spec eq "useDigital") {
	    if    ($old == 1 && $data->{useDigital} == 0) {
		$clock->destroyDigital;
		}
	    elsif ($old == 0 && $data->{useDigital} == 1) {
		$clock->createDigital;
		}
	    $clock->resize;
	    $clock->after (5, ["run" => $clock]);
	    }
	}
    } # config

sub where ($$$)
{
    my ($clock, $tick, $len) = @_;      # ticks 0 .. 59
    my ($x, $y, $a);

    my $h = ($ana_size + 1) / 2;
    $a = $tick * .104720;
    $x = $len  * sin ($a) * $ana_size / 73;
    $y = $len  * cos ($a) * $ana_size / 73;
    ($h - $x / 4, $h + $y / 4, $h + $x, $h - $y);
    } # where

sub run ($)
{
    my $clock = shift;

    my (@t) = localtime time;

    my $data = $clock->privateData;

    unless ($t[2] == $data->{Clock_h}) {
	$data->{Clock_h} = $t[2];
	$data->{useDigital} and
	    $clock->itemconfigure ("date",
		-text => &{$data->{fmtd}} (@t[3,4,5,6,7]));
	}

    unless ($t[1] == $data->{Clock_m}) {
        $data->{Clock_m} = $t[1];
	if ($data->{useAnalog}) {
	    $clock->delete ("hour");
	    $clock->createLine (
		$clock->where (($data->{Clock_h} % 12) * 5 + $t[1] / 12, 22),
		    -tags  => "hour",
		    -arrow => "none",
		    -fill  => $data->{handColor},
		    -width => $ana_size / 26);

	    $clock->delete ("min");
	    $clock->createLine (
		$clock->where ($data->{Clock_m}, 30),
		    -tags  => "min",
		    -arrow => "none",
		    -fill  => $data->{handColor},
		    -width => $ana_size / 30);
	    }
	}

    unless ($t[0] == $data->{Clock_s}) {
        $data->{Clock_s} = $t[0];
        if ($data->{useAnalog}) {
	    $clock->delete ("sec");
	    $clock->createLine (
		$clock->where ($data->{Clock_s}, 34),
		    -tags  => "sec",
		    -arrow => "none",
		    -fill  => $data->{secsColor},
		    -width => 0.8);
	    }
	$data->{useDigital} and
	    $clock->itemconfigure ("time",
		-text => &{$data->{fmtt}} (@t[2,1,0,6]));
        } 
    } # run

1;
