Tk::Date - a date/time widget for perl/Tk

    use Tk::Date;
    $date_widget = $top->Date->pack;
    $date_widget->get("%x %X");

    { y => year,
      m => month,
      d => day,
      H => hour,
      M => minute,
      S => second }

  $date = $top->Date(-datefmt => '%2d/%2m/%4y',
	  	     -fields => 'date',
		     -value => 'now')->pack;
  # this "get" only works for systems with POSIX.pm
  $top->Button(-text => 'Get date',
	       -command => sub { warn $date->get("%d/%m/%Y") })->pack;

  $top->Date(-fields  => 'date',
	     -value   => {'d' => '13', 'm' => '12', 'y' => '1957'},
	     -varfmt => 'datehash',
	    )->pack;

 - The -orient option can be only set while creating the widget. Also
   other options are only settable at create time.

 - waiting for a real perl Date/Time object
 - tie interface (-variable) does not work if the date widget gets destroyed
   (see uncommented DESTROY)
 - get and set must use the tied variable, otherwise tieying does no work
   at all
 - -from/-to is missing (limit) (or -minvalue, -maxvalue?)
 - range check (in DateNumEntryPlain::incdec)
 - am/pm
 - more interactive examples are needed for some design issues (how strong
   signal errors? ...)
 - check date-Function
 - optionally use Tk::DateEntry for the date part
 - -command is not fully implemented

# -*- perl -*-

#
# $Id: Date.pm,v 1.71 2010/10/25 20:10:31 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (C) 1997, 1998, 1999, 2000, 2001, 2005, 2007, 2008, 2010 Slaven Rezic. All rights reserved.
# This package is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: srezic@cpan.org
# WWW:  http://www.sourceforge.net/projects/srezic
#

package Tk::Date;
use Time::Local qw(timelocal);
use strict;
use vars qw($VERSION @ISA $DEBUG $has_numentryplain $has_numentry
	    @monlen %choice $en_weekdays $en_monthnames
	    $weekdays $monthnames
	   );
use Tk::Frame;
@ISA = qw(Tk::Frame);
Construct Tk::Widget 'Date';

$VERSION = '0.44';
$VERSION = eval $VERSION;

@monlen = (undef, 31, undef, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
 # XXX DST?
%choice =
  ('today'              => ['Today',     sub { time() }],
   'now'                => ['Now',       sub { time() }],
   'yesterday'          => ['Yesterday', sub { time()-86400 } ],
   'tomorrow'           => ['Tomorrow',  sub { time()+86400 } ],

   'today_midnight'     => ['Today',     sub { _begin_of_day(time()) }],
   'yesterday_midnight' => ['Yesterday', sub { _begin_of_day(time()-86400) } ],
   'tomorrow_midnight'  => ['Tomorrow',  sub { _begin_of_day(time()+86400) } ],

   'beginning_of_month' => ['Beginning of month' =>
			    sub { my(@l) = localtime;
				  $l[3] = 1;
				  _begin_of_day(timelocal(@l));
			      }],
   'end_of_month'       => ['End of month' =>
			    sub { my(@l) = localtime;
				  foreach (31, 30, 29, 28) {
				      $l[3] = $_;
				      my $t = timelocal(@l);
				      my(@l2) = localtime $t;
				      return _end_of_day($t)
					  if ($l[4] == $l2[4]);
				  }
				  die "Can't get end of month";
			      }],

   'reset'              => ['Reset',     'RESET'],
  );

$has_numentryplain = 0;
$has_numentry      = 0;

$en_weekdays = [qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday)];
$en_monthnames = [qw(January February March April May June
		     July August September October November December)];

######################################################################
package Tk::Date::NumEntryPlain;
use vars qw(@ISA);
eval {
    require Tk::NumEntryPlain;
    @ISA = qw(Tk::NumEntryPlain);
    Construct Tk::Widget 'DateNumEntryPlain';

    sub Populate {
	my($w, $args) = @_;
	$w->SUPER::Populate($args);
	$w->ConfigSpecs
	    (-frameparent    => [qw/PASSIVE/],
	     -numentryparent => [qw/PASSIVE/, undef, undef, $w],
	     -field          => [qw/PASSIVE/],
	    );
    }
    sub value { }
    sub incdec {
	my($e, $inc) = @_;
	my $val = $e->get;
	# XXX $inc == 0 -> range check
	if (defined $inc and $inc != 0) {
	    my $fw = $e->cget(-frameparent);
	    my $date_w = $fw->parent;
	    $date_w->firebutton_command($fw, $inc, $e->cget(-field));
	}
    }

    $Tk::Date::has_numentryplain++;
};

######################################################################
package Tk::Date::NumEntry;
use vars qw(@ISA);
eval {
    require Tk::NumEntryPlain;
    require Tk::NumEntry;
    Tk::NumEntry->VERSION(1.08);
    @ISA = qw(Tk::NumEntry);
    Construct Tk::Widget 'DateNumEntry';

    sub NumEntryPlainWidget { "DateNumEntryPlain" }

    sub Populate {
	my($w, $args) = @_;
	$w->SUPER::Populate($args);
	$w->Subwidget("entry")->configure
	    (-frameparent    => delete $args->{'frameparent'},
	     -numentryparent => $w);
    }

    $Tk::Date::has_numentry++;
};

######################################################################

package Tk::Date;

sub MonthOptionmenu {
    require Tk::Optionmenu;
    "Optionmenu";
}

sub Populate {
    my($w, $args) = @_;
    $w->SUPER::Populate($args);

    my $has_firebutton = 0;
    eval {
	require Tk::FireButton;
	$has_firebutton = 1;
    };

    # and now the construction-time options

    # -editable
    my $editable = 1;
    if (exists $args->{-editable}) { $editable  = delete $args->{-editable} }

    # -fields
    my $fields = 'both';
    if (exists $args->{-fields})   { $fields = delete $args->{-fields} }
    if ($fields !~ /^(date|time|both)$/) {
	die "Invalid option for -fields: must be date, time or both";
    }

    # -choices
    my $choices        = delete $args->{-choices};
    if ($choices) {
	if (ref $choices ne 'ARRAY') {
	    $choices = [$choices];
	}
    } else {
	$choices = [];
    }

    # -allarrows
    my $allarrows      = delete $args->{-allarrows};
    if (!$has_numentry and $allarrows) {
	warn "-allarrows needs Tk::NumEntry => disabled"
	    if $^W;
	$allarrows = 0;
    }

    # -monthmenu
    $w->{Configure}{-monthmenu} = delete $args->{-monthmenu};

    # -from and -to (not yet implemented)
    my $from           = delete $args->{-from}; # XXX TODO
    my $to             = delete $args->{-to};   # XXX TODO

    # -varfmt
    $w->{Configure}{-varfmt}  = delete $args->{-varfmt} || 'unixtime';

    # -orient
    my $orient         = delete $args->{-orient} || 'v';
    if ($orient !~ /^(v|h)/) {
	die "Invalid option for -orient: must be horizontal or vertical";
    } else {
	$orient = $1;
    }

    # -selectlabel
    $w->{Configure}{-selectlabel} = delete $args->{-selectlabel} || 'Select:';

    # -check
    my $check          = delete $args->{-check};

    # -weekdays
    $w->{Configure}{-weekdays} = delete $args->{-weekdays}
                                 || $w->_get_week_days;

    die "-weekdays argument should be a reference to a 7-element array"
	if (!ref $w->{Configure}{-weekdays} eq 'ARRAY' and
	    scalar $w->{Configure}{-weekdays} != 7);

    # -monthnames
    $w->{Configure}{-monthnames} = delete $args->{-monthnames}
                                   || $w->_get_month_names;
    die "-monthnames argument should be a reference to a 12-element array"
	if (!ref $w->{Configure}{-monthnames} eq 'ARRAY' and
	    scalar $w->{Configure}{-monthnames} != 12);

    # -readonly
    my $readonly = delete $args->{-readonly};

    $w->{IncFireButtons} = [];
    $w->{DecFireButtons} = [];
    $w->{NumEntries}     = [];

    my $DateEntry;
    my @DateEntryArgs;
    if ($allarrows) {
	$DateEntry = "DateNumEntry";
	if ($readonly && $Tk::NumEntry::VERSION >= 2.03) {
	    push @DateEntryArgs, -readonly => 1;
	}
    } elsif ($has_numentryplain) {
	$DateEntry = "DateNumEntryPlain";
    }

    # Construction of Date field
    if ($fields ne 'time') {
	my %range = ('d' => [1, 31],
		     'm' => [1, 12],
		    );
	my $dw = $w->Frame->pack(-side => 'left');
	$w->Advertise(dateframe => $dw);
	my @datefmt = _fmt_to_array(delete $args->{-datefmt} || "%2d.%2m.%4y");

	foreach (@datefmt) {
	    if ($_ =~ /^%(\d+)?(.)$/) {
		my($l, $k) = ($1, $2);
		if (!$editable || $k eq 'A') {  # A = weekday
		    $w->{Sub}{$k} =
		      $dw->Label(($l ? (-width => $l) : ()),
				 -borderwidth => 0,
				)->pack(-side => 'left');
		} else {
		    $w->{Var}{$k} = undef;
		    my $dne;
		    if ($k eq 'm' and $w->{Configure}{-monthmenu}) {
			my $month_i = 1;
			my $dummy; # this is only for Tk's < 800.023
			my $Optionmenu = $w->MonthOptionmenu;
			$dne = $dw->$Optionmenu
			    (-variable => \$w->{Var}{$k},
			     -textvariable => \$dummy,
			     ($check
			      ? (-command => sub { $w->inc_date($dw,0) })
                              : ()
                             ),
			    );
			$dne->addOptions(map { [$_ => $month_i++ ] }
					 @{ $w->{Configure}{-monthnames} });
		    } else {
			my $e_dne;
			if ($has_numentryplain || $has_numentry) {
			    $dne =
				$dw->$DateEntry
				    (-width => $l,
				     (exists $range{$k} ?
				      ((defined $range{$k}->[0]
					? (-minvalue => $range{$k}->[0]) : ()),
				       (defined $range{$k}->[1]
					? (-maxvalue => $range{$k}->[1]) : ()),
				      ) : ()),
				     # XXX NumEntryPlain ist buggy
				     -textvariable => \$w->{Var}{$k},
				     -frameparent => $dw,
				     -field => $k,
				     @DateEntryArgs,
				    );
			    $e_dne = $dne->Subwidget("entry") || $dne;
			} else {
			    $e_dne = $dne =
				$dw->Entry(-width => $l,
					   -textvariable => \$w->{Var}{$k});
			}
		    }

		    $w->{Sub}{$k} = $dne;
		    $dne->pack(-side => 'left');
		    if ($check) {
			$dne->bind('<FocusOut>' =>
				   sub { $w->inc_date($dw, 0)});
		    }
		    push @{$w->{NumEntries}}, $dne;
		}
		push(@{$dw->{Sub}}, $k);
		$w->{'len'}{$k} = $l;
	    } else {
		$dw->Label(-text => $_,
			   -borderwidth => 0,
			  )->pack(-side => 'left');
	    }
	}

	if ($editable && $has_firebutton && !$allarrows) {
	    my $f = $dw->Frame->pack(-side => 'left');
	    my($fb1, $fb2);
	    if ($orient eq 'h') {
		$fb2 = $f->FireButton
		  (-command => sub { $w->firebutton_command($dw, -1, 'date') },
		  )->pack(-side => 'left');
		$fb1 = $f->FireButton
		  (-command => sub { $w->firebutton_command($dw, +1, 'date') },
		  )->pack(-side => 'left');
	    } else {
		$fb1 = $f->FireButton
		  (-command => sub { $w->firebutton_command($dw, +1, 'date') },
		  )->pack;
		$fb2 = $f->FireButton
		  (-command => sub { $w->firebutton_command($dw, -1, 'date') },
		  )->pack;
	    }
	    push(@{$w->{IncFireButtons}}, $fb1);
	    push(@{$w->{DecFireButtons}}, $fb2);
	}
    }

    # spacer between Date and Time field
    if ($fields eq 'both') {
	$w->Label->pack(-side => 'left');
    }

    # Construction of Time field
    if ($fields ne 'date') {
	my %range = ('H' => [0, 23],
		     'M' => [0, 59],
		     'S' => [0, 59],
		    );
	my $tw = $w->Frame->pack(-side => 'left');
	$w->Advertise(timeframe => $tw);
	my @timefmt = _fmt_to_array(delete $args->{-timefmt} || "%2H:%2M:%2S");
	foreach (@timefmt) {
	    if ($_ =~ /^%(\d)?(.)$/) {
		my($l, $k) = ($1, $2);
		if (!$editable) {
		    $w->{Sub}{$k} =
		      $tw->Label(-width => $l,
				 -borderwidth => 0,
				)->pack(-side => 'left');
		} else {
		    $w->{Var}{$k} = undef;
		    my $dne;
		    if ($has_numentryplain || $has_numentry) {
			$dne = $tw->$DateEntry
			  (-width => $l,
			   (exists $range{$k} ?
			    ((defined $range{$k}->[0]
			      ? (-minvalue => $range{$k}->[0]) : ()),
			     (defined $range{$k}->[1]
			      ? (-maxvalue => $range{$k}->[1]) : ()),
			    ) : ()),
			   -textvariable => \$w->{Var}{$k},
			   -frameparent => $tw,
			   -field => $k,
			   @DateEntryArgs,
			  );
		    } else {
			$dne = $tw->Entry(-width => $l,
					  -textvariable => \$w->{Var}{$k});
		    }
		    $w->{Sub}{$k} = $dne;
		    $dne->pack(-side => 'left');
		    if ($check) {
			$dne->bind('<FocusOut>' =>
				   sub { $w->inc_date($tw, 0)});
		    }
		    push @{$w->{NumEntries}}, $dne;
		}
		push @{$tw->{Sub}}, $k;
		$w->{'len'}{$k} = $l;
	    } else {
		$tw->Label(-text => $_,
			   -borderwidth => 0,
			  )->pack(-side => 'left');
	    }
	}
	if ($editable && $has_firebutton && !$allarrows) {
	    my $f = $tw->Frame->pack(-side => 'left');
	    my($fb1, $fb2);
	    if ($orient eq 'h') {
		$fb2 = $f->FireButton
		  (-command => sub { $w->firebutton_command($tw, -1, 'time') },
		  )->pack(-side => 'left');
		$fb1 = $f->FireButton
		  (-command => sub { $w->firebutton_command($tw, +1, 'time') },
		  )->pack(-side => 'left');
	    } else {
		$fb1 = $f->FireButton
		  (-command => sub { $w->firebutton_command($tw, +1, 'time') },
		  )->pack;
		$fb2 = $f->FireButton
		  (-command => sub { $w->firebutton_command($tw, -1, 'time') },
		  )->pack;
	    }
	    push(@{$w->{IncFireButtons}}, $fb1);
	    push(@{$w->{DecFireButtons}}, $fb2);
	}

    }

    # Construction of choices optionmenu button for fixed dates
    if (@$choices) {
	my($b, $b_menu, $b_sub);
	my %text2time;
	if (@$choices > 1) {
	    require Tk::Menubutton;
	    $b = $w->Menubutton(-relief => 'raised',
				-borderwidth => 2,
				-takefocus => 1,
				-highlightthickness => 2,
				-text => $w->{Configure}{-selectlabel},
			       );
	    $w->Advertise('chooser' => $b);
	    $b_menu = $b->Menu;
	    $b->configure(-menu => $b_menu);
	    $b_sub = sub {
		my $time = $text2time{$_[0]};
		if (ref $time eq 'CODE') {
		    $w->set_localtime(&$time);
		} elsif ($time eq 'RESET') {
		    $w->reset;
		} else {
		    $w->set_localtime($time);
		}
		if ($w->{Configure}{-command}) {
		    $w->Callback(-command => $w);
		}
	    };
	} else {
	    $b = $w->Button;
	    $w->Advertise('chooserbutton' => $b);
	}
	$b->pack(-side => 'left');
	foreach (@$choices) {
	    my($text, $time);
	    if (ref $_ eq 'ARRAY') {
		$text = $_->[0];
		$time = $_->[1];
	    } elsif (exists $choice{$_}) {
		$text = $choice{$_}->[0];
		$time = $choice{$_}->[1];

	    } else {
		die "Unknown choice: $_";
	    }
	    $text2time{$text} = $time;

	    if (@$choices > 1) {
		$b_menu->command(-label => $text,
				 -command => sub { &$b_sub($text) },
				);
	    } else {
		$b->configure(-text => $text,
			      -command => sub {
				  if (ref $time eq 'CODE') {
				      $w->set_localtime(&$time);
				  } elsif ($time eq 'RESET') {
				      $w->reset;
				  } else {
				      $w->set_localtime($time);
				  }
				  if ($w->{Configure}{-command}) {
				      $w->Callback(-command => $w);
				  }
			      });
	    }
	}
    }

    # Default values for firebutton images.
    # Distinguish between horizontal and vertical images.
    my($incbitmap, $decbitmap);
    if ($orient eq 'v') {
	($incbitmap, $decbitmap) = ($Tk::FireButton::INCBITMAP,
				    $Tk::FireButton::DECBITMAP);
    } else {
	($incbitmap, $decbitmap) = ($Tk::FireButton::HORIZINCBITMAP,
				    $Tk::FireButton::HORIZDECBITMAP);
    }

    $w->ConfigSpecs
      (-repeatinterval => ['METHOD', 'repeatInterval', 'RepeatInterval', 50],
       -repeatdelay    => ['METHOD', 'repeatDelay',    'RepeatDelay',   500],
       -decbitmap      => ['METHOD',      'decBitmap',  'DecBitmap',
			   $decbitmap],
       -incbitmap      => ['METHOD',      'incBitmap',  'IncBitmap',
			   $incbitmap],
       -bell           => ['METHOD', 'bell', 'Bell', undef],
       -background     => ['DESCENDANTS', 'background', 'Background', undef],
       -foreground     => ['DESCENDANTS', 'foreground', 'Foreground', undef],
       -precommand     => ['CALLBACK',    'preCommand', 'PreCommand', undef],
       -command        => ['CALLBACK',    'command',    'Command',    undef],
       -variable       => ['METHOD',      'variable',   'Variable',   undef],
       -value          => ['METHOD',      'value',      'Value',      undef],
       -innerbg        => ['SETMETHOD',   'innerBg', 'InnerBg',    undef],
       -innerfg        => ['SETMETHOD',   'innerFg', 'InnerFg',    undef],
       -state          => ['METHOD',      'state',   'State',      'normal'],
      );

    $w;
}

sub value {
    my($w, $value) = @_;
    my $varfmt = $w->{Configure}{-varfmt};
    if ($value eq 'now') {
	$w->set_localtime($value);
    } elsif ($varfmt eq 'unixtime') {
	my $varref;
	tie $varref, 'Tk::Date::UnixTime', $w, $value;
	untie $varref;
    } elsif ($varfmt eq 'datehash') {
	my %varref;
	tie %varref, 'Tk::Date::DateHash', $w, $value;
	untie %varref;
    } else {
	die;
    }
}

sub decbitmap {
    my $w = shift;
    eval {
	local $SIG{__DIE__};
	$w->subwconfigure($w->{DecFireButtons}, '-bitmap', @_);
    };
}
sub incbitmap {
    my $w = shift;
    eval {
	local $SIG{__DIE__};
	$w->subwconfigure($w->{IncFireButtons}, '-bitmap', @_);
    };
}
sub repeatinterval {
    my $w = shift;
    eval {
	local $SIG{__DIE__};
	$w->subwconfigure([@{$w->{DecFireButtons}}, @{$w->{IncFireButtons}}],
			  '-repeatinterval', @_);
    };
}
sub repeatdelay {
    my $w = shift;
    eval {
	local $SIG{__DIE__};
	$w->subwconfigure([@{$w->{DecFireButtons}}, @{$w->{IncFireButtons}}],
			  '-repeatdelay', @_);
    };
}
sub bell {
    my $w = shift;
    eval {
	local $SIG{__DIE__};
	$w->subwconfigure($w->{NumEntries}, '-bell', @_);
    };
}

sub innerfg {
    my($w, $key, $val) = @_;
    $w->subwconfigure($w->{NumEntries}, '-fg', $val);
}

sub innerbg {
    my($w, $key, $val) = @_;
    $w->subwconfigure($w->{NumEntries}, '-bg', $val);
}

sub state {
    my($w, $state) = @_;
    if (@_ > 1) {
	die "Invalid state $state" if $state !~ /^(normal|disabled)$/;
	foreach my $ww (values %{ $w->{Sub} }) {
	    eval '$ww->configure("-state" => $state);';
	    #warn "$ww: $@" if $@;
	}
	my $chooser = $w->Subwidget("chooser");
	if (Tk::Exists($chooser)) {
	    $chooser->configure(-state => $state);
	}
	$w->{Configure}{"-state"} = $state;
    } else {
	$w->{Configure}{"-state"};
    }
}

sub subwconfigure {
    my($w, $subw, $key, $val) = @_;
    my @w = @$subw;
    if (@_ > 3) {
	foreach (@w) {
	    $_->configure($key => $val);
	}
    } else {
	if (@w) {
	    $w[0]->cget($key);
	} else {
	    undef;
	}
    }
}

sub variable {
    my($w, $varref) = @_;
    if (@_ > 1 and defined $varref) {
	my $varfmt = $w->{Configure}{-varfmt};
	if ($varfmt eq 'unixtime') {
	    my $savevar = $$varref;
	    tie $$varref, 'Tk::Date::UnixTime', $w, $savevar;
	} elsif ($varfmt eq 'datehash') {
	    my(%savevar) = %$varref;
	    tie %$varref, 'Tk::Date::DateHash', $w, \%savevar;
	} else {
	    tie $$varref, $varfmt, $w, $$varref;
	}
	$w->{Configure}{-variable} = $varref;
#	$w->OnDestroy(sub { $w->DESTROY });
    } else {
	$w->{Configure}{-variable};
    }
}

# should be eliminated or renamed ... only "now" is still needed
sub set_localtime {
    my($w, $setdate) = @_;
    if (defined $setdate and $setdate eq 'now') {
	$setdate = time();
    }
    if (!defined $setdate or ref $setdate ne 'HASH') {
	my @t;
	if (defined $setdate) {
	    @t = localtime $setdate;
	} else {
	    @t = localtime;
	}
	$setdate = { 'S' => $t[0],
		     'M' => $t[1],
		     'H' => $t[2],
		     'd' => $t[3],
		     'm' => $t[4]+1,
		     'y' => $t[5]+1900,
		     'A' => $t[6]
		   };
    }

    foreach (qw(y m d H M S)) { # umgekehrte Reihenfolge!
	if (defined $setdate->{$_}) {
	    $w->set_date($_, $setdate->{$_});
	}
    }
}

sub reset {
    my $w = shift;
    foreach my $key (qw(A y m d H M S)) {
	my $sw = $w->{Sub}{$key};
	if (Tk::Exists($sw)) {
	    if ($key eq 'A' || $sw->isa('Tk::Label')) {
		$sw->configure(-text => '');
	    } elsif ($sw->isa('Tk::Optionmenu')) {
		# XXX hackish!
		$ {$sw->cget('-variable')} = 1;
		$ {$sw->cget('-textvariable')} = $w->{Configure}{-monthnames}->[0];
	    } else {
		$sw->delete(0, 'end');
		$sw->insert(0, '');
	    }
	}
    }
}

sub get {
    my($w, $fmt) = @_;
    $fmt = '%s' if !defined $fmt;
    my %date;
    foreach (qw(y m d H M S)) {
	$date{$_} = $w->get_date($_, 1);
	if ($date{$_} eq '') { $date{$_} = 0 }
    }
    $date{'m'}--;
    $date{'y'}-=1900;
# XXX weekday should also be set
    # -1: let strftime/mktime divine whether summer time is in effect
    if ($fmt eq '%s') {
	# %s is an (BSD?) extension to strftime and not part of POSIX. Use
	# timelocal (this is the perl mktime) instead.
        my $ret;
	$ret = eval {
	    local $SIG{'__DIE__'};
	    timelocal(@date{qw(S M H d m y)});
	};
	return $ret;
    } else {
	my $ret;
	my $errors = "";
	$ret = eval {
	    require POSIX;
	    POSIX::strftime($fmt, @date{qw(S M H d m y)}, 0, 0, -1);
	};
	return $ret if (!$@);
	$errors .= $@;
	$ret = eval {
	    require Date::Format;
	    Date::Format::strftime($fmt, [@date{qw(S M H d m y)}, 0, 0, -1]);
	};
	return $ret if (!$@);
	$errors .= $@;
	die "Can't access strftime function." .
	  "You have to install either the POSIX or Date::Format module.\n" .
	  "Detailed errors:\n$errors";
    }
}

# Get the date/time value for key $key (S,M,H,d,m,y)
# If $defined is set to true, always get a defined value, i.e. return
# the current time if the key is not set in the widget.
sub get_date {
    my($w, $key, $defined) = @_;
    my $sw = $w->{Sub}{$key};
    if (Tk::Exists($sw)) {
	if ($sw->isa('Tk::Entry') ||
	    $sw->isa('Tk::NumEntry')) {
	    my $r;
	    if (ref $w->{Var}{$key} eq 'SCALAR') {
		$r = $ {$w->{Var}{$key}}; # XXX NumEntryPlain ist buggy
	    } else {
		$r = $sw->get;
	    }
	    if (!defined $r or $r eq '' && $defined) {
		$r = _now($key);
	    }
	    $r;
	} elsif ($sw->isa('Tk::Optionmenu')) {
	    # XXX hackish!
	    $ {$sw->cget('-variable')};
	} elsif ($sw->isa('Tk::Label')) {
	    $sw->cget(-text);
	}
    } elsif ($defined) {
	_now($key);
    }
}

sub set_date {
    my($w, $key, $value, %args) = @_;
    $value = 0 if !defined $value; # XXX ???

    if ($key eq 'd') {
	if (!$args{-correcting}) {
	    if ($value < 1) {
		my $m = $w->set_date('m', $w->get_date('m', 1)-1);
		$value = _monlen($m, $w->get_date('y', 1));
	    } else {
		my $m = $w->get_date('m', 1);
		if (defined $m and $m ne '') {
		    my $y = $w->get_date('y', 1);
		    if (defined $y and $y ne '' and $value > _monlen($m, $y)) {
			$value = 1;
			$w->set_date('m', $m+1);
		    }
		}
	    }
	}
    } elsif ($key eq 'm') {
	if ($value < 1) {
	    $value = 12;
	    $w->set_date('y', $w->get_date('y', 1)-1);
	} elsif ($value > 12) {
	    $value = 1;
	    $w->set_date('y', $w->get_date('y', 1)+1);
	}
	# maybe correct day
	my $d = $w->get_date('d', 1);
	if (defined $d && $d ne '') {
	    my $max_d = _monlen($value, $w->get_date('y', 1));
	    if ($d > $max_d) {
		$w->set_date('d', $max_d, -correcting => 1);
  	    }
	}
    } elsif ($key eq 'H') {
	if ($value < 0) {
	    $value = 23;
	    $w->set_date('d', $w->get_date('d', 1)-1);
	} elsif ($value > 23) {
	    $value = 0;
	    $w->set_date('d', $w->get_date('d', 1)+1);
	}
    } elsif ($key eq 'y') {
	# maybe correct day for leap years
	my $d = $w->get_date('d', 1);
	if (defined $d and $d ne '') {
	    my $max_d = _monlen($w->get_date('m', 1), $value);
	    if ($d > $max_d) {
		$w->set_date('d', $max_d);
 	    }
	}
    } elsif ($key eq 'M') {
	if ($value < 0) {
	    $value = 59;
	    $w->set_date('H', $w->get_date('H', 1)-1);
	} elsif ($value > 59) {
	    $value = 0;
	    $w->set_date('H', $w->get_date('H', 1)+1);
	}
    } elsif ($key eq 'S') {
	if ($value < 0) {
	    $value = 59;
	    $w->set_date('M', $w->get_date('M', 1)-1);
	} elsif ($value > 59) {
	    $value = 0;
	    $w->set_date('M', $w->get_date('M', 1)+1);
	}
    }

    my $sw = $w->{Sub}{$key};
    if (Tk::Exists($sw)) {
	if ($key eq 'A') {
	    $sw->configure(-text => $value);
	} else {
	    my $v = sprintf("%0".($w->{'len'}{$key}||"")."d", $value);
	    if ($sw->isa('Tk::Entry') ||
		$sw->isa('Tk::NumEntry')) {
		$sw->delete(0, 'end');
		$sw->insert(0, $v);
	    } elsif ($sw->isa('Tk::Optionmenu')) {
		# XXX hackish!
		$ {$sw->cget('-variable')} = $v;
		$ {$sw->cget('-textvariable')} = $w->{Configure}{-monthnames}->[$v-1];
	    } elsif ($sw->isa('Tk::Label')) {
		$sw->configure(-text => $v);
	    }
	}
    }

    if ($key =~ /^[dmy]$/) {
	my $d = $w->get_date('d', 1);
	my $m = $w->get_date('m', 1);
	my $y = $w->get_date('y', 1);
	if ($d ne '' and $m ne '' and $y ne '') {
	    my $t;
	    eval {
		$t = timelocal(0,0,0, $d, $m-1, $y-1900);
	    };
	    if (!$@ and defined $t) {
		$w->set_date('A', $w->{Configure}{-weekdays}->[(localtime($t))[6]]);
	    }
	}
    }

    $value;
}

sub _monlen {
    my($mon, $year) = @_;
    if ($mon != 2) {
	$monlen[$mon];
    } elsif ($year % 4 == 0 &&
	     (($year % 100 != 0) || ($year % 400 == 0))) {
	29;
    } else {
	28;
    }
}

sub _get_week_days {
    return $weekdays if $weekdays;
    eval {
	my $loc = _get_datetime_locale();
	my @weekdays = @{ $loc->can('day_format_wide') ? $loc->day_format_wide : $loc->day_names }; # clone!
	unshift @weekdays, pop @weekdays;
	$weekdays = \@weekdays;
    };
    return $weekdays if $weekdays;
    warn $@ if $@ && $DEBUG;
    eval {
	require POSIX;
	POSIX->VERSION(1.03);
	# prefer POSIX because of localized weekday names
	my $locale_charset = _guess_time_locale_charset();
	my $_weekdays = [];
	foreach my $day_i (6 .. 12) { # 2000-08-06 till 2000-08-12
	    my $wday = _decoded_strftime("%A", [0,0,0,$day_i,8-1,2000-1900], $locale_charset);
	    if ($wday eq '' || $wday =~ /^\?/) {
		die "Can't get weekday name from locale";
	    }
	    push @$_weekdays, $wday;
	}
	$weekdays = $_weekdays;
    };
    warn $@ if $@ && $DEBUG;
    if (!$weekdays) {
	$weekdays = $en_weekdays;
    }
    $weekdays;
}

sub _get_month_names {
    return $monthnames if $monthnames;
    eval {
	my $loc = _get_datetime_locale();
	my @monthnames = @{ $loc->can('month_format_wide') ? $loc->month_format_wide : $loc->month_names }; # clone!
	$monthnames = \@monthnames;
    };
    return $monthnames if $monthnames;
    warn $@ if $@ && $DEBUG;
    eval {
	require POSIX;
	# prefer POSIX because of localized month names
	my $locale_charset = _guess_time_locale_charset();
	my $_monthnames = [];
	foreach my $month_i (1 .. 12) {
	    my $mname = _decoded_strftime("%B", [0,0,0,1,$month_i-1,1970], $locale_charset);
	    if ($mname eq '' || $mname =~ /^\?/) {
		die "Can't get month name from locale";
	    }
	    push @$_monthnames, $mname;
	}
	$monthnames = $_monthnames;
    };
    if (!$monthnames) {
	$monthnames = $en_monthnames;
    }
    $monthnames;
}

sub _now {
    my($k) = @_;
    my @now = localtime;
    if    ($k eq 'y') { $now[5]+1900 }
    elsif ($k eq 'm') { $now[4]+1 }
    elsif ($k eq 'd') { $now[3] }
    elsif ($k eq 'H') { $now[2] }
    elsif ($k eq 'M') { $now[1] }
    elsif ($k eq 'S') { $now[0] }
    else { @now }
}

sub inc_date {
    my($dw, $fw, $inc, $current_nw) = @_;
    if ($inc != 0) { # $inc == 0: only check and correct date
	if (!$current_nw) {
	    $current_nw = $dw->focusCurrent;
	}
	if ($current_nw) {
	    # search the active numentry widget
	    foreach (@{$fw->{Sub}}) {
		if ($current_nw eq $dw->{Sub}{$_} or
		    ($current_nw->parent && $current_nw->parent eq $dw->{Sub}{$_})
		   ) {
		    $dw->set_date($_, $dw->get_date($_, 1)+$inc);
		    return;
		}
	    }
	}
    }

    my @check_order;
    if (defined $dw->{SubWidget}{'dateframe'} and
	$fw eq $dw->{SubWidget}{'dateframe'}) {
	@check_order = qw(d m y);
    } else {
	@check_order = qw(S M H);
    }

    # search an existing date entry field
    my $entry_field;
    foreach (@check_order) {
	if (defined $dw->{Sub}{$_}) {
	    $entry_field = $_;
	    last;
	}
    }
    if (defined $entry_field) {
	$dw->set_date($entry_field, $dw->get_date($entry_field, 1)+$inc);
    }
}

sub firebutton_command {
    my($w, $cw, $inc, $type) = @_;
    if ($w->{Configure}{-precommand}) {
	return unless $w->Callback(-precommand => $w, $type, $inc);
    }
    my $sub_w = $w->{Sub}{$type};
    $w->inc_date($cw, $inc, $sub_w);
    if ($w->{Configure}{-command}) {
	$w->Callback(-command => $w, $type, $inc);
    }
}

sub _fmt_to_array {
    my $fmt = shift;
    my @a = split(/(%\d*[dmyAHMS])/, $fmt);
    shift @a if $a[0] eq '';
    @a;
}

sub _begin_of_day {
    my $s = shift;
    my(@l) = localtime $s;
    timelocal(0,0,0,$l[3],$l[4],$l[5]);
}

sub _end_of_day {
    my $s = shift;
    my(@l) = localtime $s;
    timelocal(59,59,23,$l[3],$l[4],$l[5]);
}

sub _Destroyed {
    my $w = shift;
    if ($] >= 5.00452) {
	my $varref = $w->{Configure}{'-variable'};
	if (defined $varref) {
	    if (ref $varref eq 'SCALAR') {
		untie $$varref;
	    } elsif (ref $varref eq 'HASH') {
		untie %$varref;
	    } else {
		warn "Unexpected ref type for -variable: <" . ref $varref . ">";
	    }
	}
    }
    $w->SUPER::DESTROY($w);
}

# Call only if POSIX is already loaded
sub _guess_time_locale_charset {
    my $charset;
    my $locale_name = eval {
	# Is setlocale and LC_TIME available everywhere?
	POSIX::setlocale(POSIX::LC_TIME());
    };
    warn $@ if $@ && $DEBUG;
    my $full_locale_name = $locale_name;
    $locale_name =~ s{^[^.]+\.}{};
    $locale_name =~ s{\@.*}{};
    if ($locale_name) {
	if      ($locale_name =~ m{^utf-?8$}i) {
	    $charset = "utf-8";
	} elsif ($locale_name =~ m{^iso[-_]?8859-?(\d+)$}i) {
	    $charset = "iso-8859-$1";
	} elsif ($locale_name =~ m{^(?:cp|ansi)-?(\d+)$}i) {
	    $charset = "cp$1";
	} elsif ($locale_name =~ m{^koi8-.$}i) {
	    $charset = lc $locale_name;
	} elsif ($locale_name =~ m{^euc-?(cn|jp|kr)$}i) {
	    $charset = "euc-" . lc $1;
	} elsif ($locale_name =~ m{^euc$}i && $full_locale_name =~ m{(kr|cn|jp)}i) {
	    $charset = "euc-" . lc $1;
	} elsif ($locale_name =~ m{^gb-?18030$}i && eval { require Encode::HanExtra; 1; }) {
	    $charset = "gb18030";
	} elsif ($locale_name =~ m{^gb-?(\d+|k)$}i) {
	    $charset = "gb" . lc $1;
	} elsif ($locale_name =~ m{^big5-?hkscs$}i) {
	    $charset = "big5-hkscs";
	} elsif ($locale_name =~ m{^big5$}i) {
	    $charset = "big5";
	} elsif ($locale_name =~ m{^s(?:hift)?-?jis$}i) {
	    $charset = "shiftjis";
	} elsif ($locale_name =~ m{^(?:us-)?ascii$}i) {
	    $charset = "ascii";
	}
	## More encodings are missing:
	## (Following seen on FreeBSD 6.2)
	##   cp1131: http://source.icu-project.org/repos/icu/icu/trunk/source/data/mappings/ibm-1131_P100-1997.ucm
	##   iscii-dev
	##   armscii-8
	##   pt154 (kazachstan?)
	## (Following seen on Solaris 10)
	##   PCK (japanese)
	##   TIS620 (thai)
	##   BIG5HK
	##   zh_TW.EUC (use euc-cn?)
    }
    $charset;
}

# Call only if POSIX is already loaded
sub _decoded_strftime {
    my($fmt, $localtime_ref, $locale_charset) = @_;
    my $date_string = POSIX::strftime($fmt, @$localtime_ref);
    return $date_string if (!$locale_charset);
    eval {
	require Encode;
	$date_string = Encode::decode($locale_charset, $date_string, Encode::LEAVE_SRC());
    };
    warn $@ if $@ && $DEBUG;
    return $date_string;
   
}

sub _get_datetime_locale {
    require DateTime::Locale;
    require POSIX;
    my $locale_name = POSIX::setlocale(POSIX::LC_TIME());
    my $loc = DateTime::Locale->load($locale_name);
    $loc;
}

######################################################################

package Tk::Date::UnixTime;

sub TIESCALAR {
    my($class, $w, $init) = @_;
    my $self = {};
    $self->{Widget} = $w;
    bless $self, $class;
    if (defined $init) {
	$self->STORE($init);
    }
    $self;
}

sub STORE {
    my($self, $value) = @_;
    my(@t) = localtime $value;
    my $setdate = { 'S' => $t[0],
		    'M' => $t[1],
		    'H' => $t[2],
		    'd' => $t[3],
		    'm' => $t[4]+1,
		    'y' => $t[5]+1900,
		    'A' => $t[6]
		  };
    foreach (qw(y m d H M S)) { # umgekehrte Reihenfolge!
	$self->{Widget}->set_date($_, $setdate->{$_});
    }
}

sub FETCH {
    my $self = shift;
    $self->{Widget}->get("%s");
}

######################################################################

package Tk::Date::DateHash;

sub TIEHASH {
    my($class, $w, $init) = @_;
    my $self = {};
    $self->{Widget} = $w;
    bless $self, $class;
    if (defined $init) {
	while(my($k, $v) = each %$init) {
	    $self->STORE($k, $v);
	}
    }
    $self;
}

sub STORE {
    my($self, $field, $value) = @_;
    $self->{Widget}->set_date($field, $value);
}

sub FETCH {
    my($self, $field) = @_;
    $self->{Widget}->get_date($field, 1);
}

sub FIRSTKEY {
    my $self = shift;
    $self->{Key} = -1;
    $self->NEXTKEY;
}

sub NEXTKEY {
    my $self = shift;
    return undef if (++$self->{Key} > 5);
    (qw(y m d H M S))[$self->{Key}];
}

######################################################################

1;

__END__