package ATR::Tk::UpdateFieldDate;

use strict;
use warnings;
use base  qw(ATR::Tk::UpdateField Tk::DateEntry);
Tk::Widget->Construct('UFDate');

=head1 NAME

ATR::Tk::UpdateFieldDate - data-tracking date widget

=head1 DESCRIPTION

=cut

# $Id: UpdateFieldDate.pm,v 1.16 2005/04/15 17:31:11 mca Exp $

#----------------------------------------------------------------------------
#
# DateEntry methods

sub atrdateFormat {
    # XXX: Subclass DateEntry to hook changes/edits
    my ($self, @YMD) = @_;
    # nb. This is a bad time to look at $$textvariable because:
    #  - we can be called often for various things not related to value changes
    #  - when Tk::DateEntry subclass calls, ($$textvariable eq "") until after we return
    return ATR::Date->newDMYHMSlocal(@YMD[2, 1, 0], 0, 0, 0)->getUI; # 00:00:00 on date
#    return $self->defaultFormat(@YMD);
}

# When base Tk::DateEntry has done stuff, we need to hook both of
# these to find edits
sub updateDate {
    my ($self, @args) = @_;
    $self->SUPER::updateDate(@args); # currently no @args
    $self->detectEdit;
}
sub popDown {
    my ($self, @args) = @_;
    $self->SUPER::popDown(@args); # currently no @args
    $self->detectEdit;
}
# XXX: Edit state, popdown state, text changes etc. all need tying together a bit more...?

sub atrdateParse {
    my $self = shift;
    my $str = shift;
    my @shownDMY = eval {
	ATR::Date->new_GuessDate($str, '00:00:00')->getDMYHMSlocal;
    };
    return @shownDMY ? @shownDMY[2,1,0] : ();
}

sub getVisibleYMD {
    my $self = shift;
    return $self->Callback(-parsecmd => $self->get);
}

sub ufCancel {
    my ($self, @args) = @_;
    $self->popDown; # remove the calendar part, if it's visible
    $self->SUPER::ufCancel(@args);
}


#----------------------------------------------------------------------------
#
# UpdateField methods

sub atrPopulatePost {
    my ($self, $args) = @_;

    # Override to fix DateEntry's breaking of the option database for width
    # Default 12 = 10 ("dd/mm/yyyy") + 2 for the arrow
    my $e = $self->Subwidget('entry') || die "can't get DateEntry's entry";
    $self->ConfigSpecs(-width => [$e, "width", "Width", 12],
		       -font => ['DESCENDANTS', 'font', 'Font']);

    # Put the popUp button inside the widget: fixes printing alignment
    my $b = $self->Subwidget('arrow');
    $b->configure(-border => 2,
		  -takefocus => 0,
		  -highlightthickness => 0);
    $b->packForget;
    $self->bind('<Enter>' => [ $self => 'insetDropdownButton' ]);

    $self->SUPER::atrPopulatePost($args);
}

sub accessorsChanged {
    my $self = shift;

    $self->configure(
		     -configcmd => sub {
			 # called for each day button, including the blank ones for next/prev month
			 my %args = @_;
			 return unless $args{-date};  # an invisible button
			 my $dateEntry = $args{-widget}; # whole widget
			 my $dayBtn = $args{-datewidget};
			 my ($D,$M,$Y) = @{ $args{-date} };

			 my $configDate = join "/", $D+0, $M+0, $Y+0;

			 # Highlight 'today'
# XXX: put special days config info at $self->redletter->{yyyymmdd}->{-key} = 'value'
			 my @nowDMY = ATR::Date->now->getDMYHMSlocal;
			 my $nowDate = join "/", @nowDMY[0,1,2];

			 $dayBtn->configure(-background => ($configDate eq $nowDate ? 'yellow' : 'white'));

			 # Highlight currently displayed day
			 my @shownYMD = $dateEntry->getVisibleYMD;
# XXX: start using ATR::Date internally
			 my $shownDate = @shownYMD ? join "/", @shownYMD[2,1,0] : '';
			 $dayBtn->configure(-foreground => ($configDate eq $shownDate ? 'red' : 'black'));
#warn "cmp: $shownDate (@shownDMY)\t$configDate\t$nowDate\n";
		     },
		     # We use the GTx 'today', so we don't need these:
		     #   -todaybackground => 'yellow',
		     #   -buttonbackground => 'white',
		     -formatcmd => [ $self, 'atrdateFormat' ],
		     -parsecmd => [ $self, 'atrdateParse' ],
		     # We use ATR::Date's getUI to format the dates, currently DD/MM/YYYY
		     #   -dateformat => 3, # DD/MM/YYYY
		    );

    $self->bindFocusHighlight;
    my $readWrite = $self->data->canSave;
    $self->bindEntryKeystrokes($readWrite);
    $self->configure(-normalcolour => $readWrite ? 'white' : 'LightGrey');

# Tk::DateEntry doesn't use Tk::Derived, and our use means we must
# ensure Tk::DateEntry::configure is called.  Doing it this way means
# we lose some error checking.

    Tk::DateEntry::configure($self,
			     -weekstart => 1, # start on Monday
			     -daynames => [qw[Su M Tu W Th F Sa]],
			     -font => $self->getFont('data'),
			    );
}

sub validateGuiValue {
    my $self = shift;
    my $current = $self->get;
    my $corrected = $current;
    my $ok = 0;

    if ($current !~ /\S/) {
	# Empty date - may well be valid
	$corrected = "";
	$ok = 1;
    }

    my @YMD = $self->getVisibleYMD;
    if (@YMD) {
	# Value is a valid date, reformat to canonical
	$corrected = $self->atrdateFormat(@YMD);
	$ok = 1;
    }

    if ($ok) {
	if ($corrected ne $current) {
	    # We made a formatting change to the value
	    $self->set($corrected);
	}
	return undef; # "no problem"
    } else {
	return "Invalid date";
    }
}

sub focusOut {
    my ($self, @args) = @_;

    # Remove the calendar part, if it's visible
    $self->popDown;
    # Tk::DateEntry:72 says "Not uses anymore due to problems with grab"

    # Previous version at
    # http://search.cpan.org/src/SREZIC/Tk-DateEntry-1.35/DateEntry.pm
    # Code seems strange.

    # This is simple, I've not had any problems yet...  Could put the
    # popDown in an afterIdle?

    $self->SUPER::focusOut(@args);
}


=head2 getDate($defaultTime)

Returns an L<ATR::Date> for the current time in the widget, so that we
can start migrating to doing the conversion here rather than per
caller.

$defaultTime is used with new_GuessDate, and itself defaults to
00:00:00.

NB. This is the GUI text date, not the underlying database date - XXX: will need access to that also.

May die if your GUI date text is invalid...  but it may not always be this way.

=cut

sub getDate { # on the UF side, would like to call this 'get', but there is already a 'get' which returns text
    my ($self, $defaultTime) = @_;
    $defaultTime = '00:00:00' unless defined $defaultTime;
    return ATR::Date->new_GuessDate($self->get, $defaultTime);
}

sub set { # XXX: general purpose set? superclass should detectEdit
    my ($self, $text) = @_;
    $self->delete(0, 'end');
    $self->insert(0, $text);
    $self->icursor('end');

    # Updating the text variable is important, because if widget type
    # changes we're going to be blown away and recreated; may not be
    # told what the GUI value is supposed to be.
# XXX: need hooks to keep editted value saved in the textvariable
    my $tv = $self->cget('-textvariable');
    if ($tv) {
	$$tv = $text;
    } else {
	warn "Can't do $self->set($text): no textvariable\n";
    }

    $self->detectEdit;
}


1;
