package ATR::Tk::UpdateField;

use strict;
use warnings;
use base 'Tk::Derived';

use Time::HiRes qw(gettimeofday tv_interval);


=head1 NAME

ATR::Tk::UpdateField - base class for data-tracking widgets

=head1 DESCRIPTION

=cut

# $Id: UpdateField.pm,v 1.17 2005/05/06 09:42:31 mca Exp $

#----------------------------------------------------------------------------
#
# Tk initialisation gubbins bumps against the multiple inheritance.
# Try to confine this to a small area of code...

use NEXT; # argh, save me from the evil

sub new {
    my ($proto, @args) = @_;
    my $self = $proto->NEXT::ACTUAL::new(@args);
    $self->accessorsChanged;
    return $self;
}

# Don't override this in sub-classes, it calls the atrPopulate* hooks
# for you
sub Populate {
    my ($self, $args) = @_;
    $self->atrPopulatePre($args);
    $self->NEXT::ACTUAL::Populate($args);
    $self->atrPopulatePost($args);
}

# Called before what would be SUPER::Populate (so you can diddle the $args)
sub atrPopulatePre {
    my ($self, $args) = @_;
    $self->ConfigSpecs(-datamodel => ['PASSIVE', 'DataModel', 'dataModel', undef],
		       -normalcolour => [qw[METHOD NormalColour normalColour white]],
		      );
}

# Called after what would be SUPER::Populate (so you can diddle the created widgets)
sub atrPopulatePost {
    my ($self, $args) = @_;
    $self->prototypeHook if $self->can('prototypeHook'); # XXX:DEBUG temporary
}

sub accessorsChanged {
    # A hook for subclasses.
    # This will include things like the data model's properties
    # changing - it will need to call us
}

### Will be called for each MainWindow created, when the first UF is added to it
#
# sub ClassInit {
#     my ($class, $mw) = @_;
#     $class->NEXT::ClassInit($mw);
#     $mw->bind($class, '<Configure>' => 'tkSizeChange');
# }


#----------------------------------------------------------------------------

#sub data { $_[0]->privateData->{datamodel} }
sub data { $_[0]->cget('-datamodel') }

sub getTextRef {
    my $self = shift;
    return $self->cget('-textvariable');
}

# subclass may calculate this instead...  but it should beware things trying to write
sub normalcolour {
    my $self = shift;
    return $self->privateData->{normalColour} if !@_; # cget
    my $newval = shift;

    $self->privateData->{normalColour} = $newval;
}

# Return a string describing a problem with the user's current field
# value, or undef if no problem.  Default: anything goes.
# May have side-effect of changing (e.g. minor correction) to the GUI value.
sub validateGuiValue { undef }

#----------------------------------------------------------------------------
#
# Keypress bindings

sub bindEntryKeystrokes {
    # Used (at least) by Entry & DateEntry
    my ($self, $readWrite) = @_;
    if ($readWrite) {
	$self->configure(-state => 'normal');
	$self->bind('<KeyPress-Escape>' => [ $self, 'ufCancel' ]);
	$self->bind('<Return>'          => [ $self, 'ufFinish' ]);
# XXX: paste event? $self->bind('<Button>'          => [ $self, 'ufKeystroke', Tk::Ev('K') ]);
	$self->bind('<KeyPress>'        => [ $self, 'ufKeystroke', Tk::Ev('K') ]);
    } else {
	$self->configure(-state => 'disabled');
    }
}

#----------------------------------------------------------------------------
#
# GUI event handling

sub ufClick     {
    my $self = shift;
    my @ret = $self->data->doCallback('click', @_);
    my $menu = $self->popMenu(@ret) if @ret;
}
sub ufCancel    { (shift)->data->cancel(@_)    }
sub ufFinish    { (shift)->data->finish(@_)    } # XXX: if still focussed, skip to next field
sub ufKeystroke { (shift)->data->keystroke(@_) }
sub detectEdit  { $_[0]->ufKeystroke('(maybe)') } # XXX: Need proper comparison, at least for date field: this is a hack


#----------------------------------------------------------------------------
#
# Callbacks for "auto-highlight contents"
# Suitable for Entry & similar.  Hooked from subclass Populate.

sub bindFocusHighlight {
    my $self = shift;
    $self->bind('<FocusIn>'  => [ $self, 'focusIn'  ]);
    $self->bind('<FocusOut>' => [ $self, 'focusOut' ]);
}
sub focusIn {
    my ($self) = @_;
    if (!$self->{lastFocus} || $self->{lastFocus} != $self) {
	$self->selectionRange(0, 'end');
#	$self->icursor('end');
    }
    $self->{lastFocus} = $self;
}
sub focusOut {
    my ($self) = @_;
    if ($self->{lastFocus} && $self->{lastFocus} == $self) {
	undef $self->{lastFocus};
	$self->ufFinish; # extra finish hook for whole-card-commit
    }
}

# 'Button' has one of these, but we need feedback any bad field
sub flash {
    my $self = shift;
    my ($fg, $bg) = ($self->cget('-fg') || 'black',
		     $self->cget('-bg') || 'white', # can be undef somehow
		    );
    my $start = [gettimeofday];
    while (tv_interval($start, [gettimeofday]) < 0.25) {
	$self->configure(-fg => $bg, -bg => $fg);
	$self->update;
	Time::HiRes::sleep(0.05);
	$self->configure(-fg => $fg, -bg => $bg);
	$self->update;
	Time::HiRes::sleep(0.05);
    }
}

# a tk callback suitable for use on <Enter> event; button removed on a timer
sub insetDropdownButton {
    my $self = shift;
    my $b = $self->Subwidget('arrow');
    my $e = $self->Subwidget('entry');

    # Fix the bitmap to our colour scheme XXX: should be in optdb .. does that work?
    $b->configure(-background => 'purple', -foreground => 'black');

    # Put it on top of the text
    $b->place(-in => $e, -anchor => 'e',
	      -relx => 1.0, -x => 0,
	      -rely => 0.5);
    # Hide it after the pointer leaves, not on the Leave event because
    # we get one of those when the pointer goes from $e to $b
    my $delay = 750;
    $self->after($delay, [ \&__insetDropdownUnplace, $delay, $b, $e ]);
}

sub __insetDropdownUnplace {
    my ($delay, $button, $entry) = @_;
    my ($mx, $my) = $entry->pointerxy; # relative to (virtual) root window; or -1 for off-screen
    my ($wx, $wy) = ($entry->rootx, $entry->rooty);
    my ($ww, $wh) = ($entry->width, $entry->height); # may have changed since $hide was made, so reload
    if ($mx < $wx || $mx > $wx+$ww || $my < $wy || $my > $wy+$wh) {
	# pointer not inside the widget
	$button->placeForget;
    } else {
	$entry->after($delay, [ \&__insetDropdownUnplace, $delay, $button, $entry ]); # try again soon
    }
}


#----------------------------------------------------------------------------
#
# Size hackery: layout for intended size font, not actual font

# Duplicate the size calculations from tkEntry.c:EntryComputeGeometry,
# but with fractional font size if available, and with exact string if no prefWidth
# also the configured width becomes a maximum...
sub wantFracSize {
    my ($self, $txt) = @_;
    $txt = $self->get if !defined $txt; # $txt is mostly undef, but UFList sets it to shrink the box

    my $font = $self->cget('-font');
    my $metricsMethod = $font->can('fracMetrics') ? 'fracMetrics' : 'metrics';
    my $measureMethod = $font->can('fracMeasure') ? 'fracMeasure' : 'measure';

    # from tkEntry.c: Pixels on left & right, taken up by XPAD + borderWidth + highlightWidth
    #                 XPAD and YPAD hardwired = 1
    my $inset = 1 + $self->cget('-borderwidth') + $self->cget('-highlightthickness');

    my $height    = $font->$metricsMethod('-linespace') + 2 * $inset;
    my $width;

    # Size to actual text; allow for -show option
    my $show = $self->cget('-show');
    $txt = $show x length($txt) if defined $show;
    $txt = "0" if $txt eq "";
    $width = $font->$measureMethod($txt) + 2 * $inset;

    my $prefWidth = $self->cget('-width');
    if ($prefWidth) {
	my $avgWidth = $font->$measureMethod('0') || 1;
	my $maxWidth = $prefWidth * $avgWidth + 2 * $inset;
	$width = $maxWidth if $width > $maxWidth;
    }

    return ($width, $height); # pixels
}

# This getFont delegates to the AtrCard ancestor  XXX: possibly not ideal (ties UF to AtrCard)...  needs more thought
sub getFont {
    my ($self, $which) = @_;
    return $self->toplevel->furnitureFont
      if $which eq 'furniture'; # bodge allows this to work for non-AtrCards, if inside an AtrMain
    return $self->findAtrCard->getFont($which);
}

sub findAtrCard { # XXX: again, ties UF to AtrCard
    my $self = shift;
    my $w = $self;
    while (1) {
	my $par = $w->parent;
	my $old = $w;
	$w = $par;
	die "Cannot find AtrCard for $self"
	  if !defined $w || $w == $old; # got to the top
	last if $w->isa('ATR::Tk::AtrCard');
    }
    return $w;
}

1;
