package ATR::Tk::UpdateEntry;

use strict;
use warnings;

# use Carp; # croak seems not to be Tk-friendly

use base qw(Tk::Derived Tk::Frame);
Tk::Widget->Construct('UpdateEntry');

# NOTE! Tk::Frame provides undocumented 'label' Subwidget and configure option
#       these will cause confusion if mixed with ours

use Tk::Label;

use ATR::Tk::UpdateFieldEntry;
use ATR::Tk::UpdateFieldButton;
use ATR::Tk::UpdateFieldDate;
use ATR::Tk::UpdateFieldLabel;
use ATR::Tk::UpdateFieldList;

=head1 NAME

ATR::Tk::UpdateEntry - GeneriTrack-linked text field

=head1 DESCRIPTION

A labelled field which can keep track of its current value, whether
the user changed it, sending the new value off somewhere; colour coded
to indicate states (not modified, modified, saved...).


=head2 $frame-E<gt>UpdateEntry(%ue_params, %frame_params)

%ue_params are the key/value pair list for this class,

=over 4

=item C<-labelpos>

Specifies the packing arrangement of subwidgets inside this one.
Should be one of C<n s e w none>, defaults to 'w'.

The field takes the opposite compass point, or the centre if 'none'.

=item C<-label>

Text for the field description, default 'somefield'.

=item C<-textvariable>

Scalar ref for the data field, in the usual Tk way.  Default is a
generated scalarref pointing to a fresh C<undef>.

Currently cannot be changed via C<configure>.

=item C<-datafont>, C<-labelfont>

L<Tk::Font>s to use (optional).

=back

Other params (%frame_params) are passed down to the superclass
L<Tk::Frame>.

=cut

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

    # Grab the args we want
    my $_data;
    $self->privateData->{textvariable} = delete $args->{-textvariable} || \$_data;

    # Populate the superclass
    #   nb. Frame will notice any arg with /^-label\w+/
    #   so we hide them
    {
	my %hide;
	foreach my $key (grep /^-label/, keys %$args) {
	    $hide{$key} = delete $args->{$key};
	}
	$self->SUPER::Populate($args);
	foreach my $key (keys %hide) {
	    $args->{$key} = delete $hide{$key};
	}
    }

    $self->ConfigSpecs(
		       -labelpos => [qw[ METHOD LabelPos labelpos w ]],
		       -label    => [qw[ METHOD Label    label    somefield ]],
		       -datafont  => [qw[ METHOD DataFont dataFont ]],
		       -labelfont => [qw[ METHOD LabelFont labelFont ]],
		       -fieldtype => [qw[ METHOD FieldType fieldType entry]],
		      );

    # Initialise data to unknowns
    $self->_setValue('db');
    $self->_setValue('gui');
}

#sub findCard {
#    my $self = shift;
#    my $parent = $self->parent;
#    while (1) {
#	return $parent if $parent->isa('ATR::Tk::Card'); # what we wanted
#	return undef if $parent->isa('Tk::Toplevel'); # we didn't find one
#	my $prev = $parent;
#	$parent = $parent->parent;
#	return undef if $prev == $parent; # some other form of not finding one
#    }
#}

# read accessors
sub getTextRef {
    my $self = shift;
    my $field = $self->getUpdateField;
    return $field->getTextRef if $field;
    return $self->privateData->{textvariable};
}

sub getUpdateField {
    my $self = shift;
    my $field = $self->_subwidg('field');
    return $field if $field && $field->isa('ATR::Tk::UpdateField');
    return undef;
}


# internal monotonic sequence generator
sub getSeq     { ++( $_[0]->privateData->{sequence} ) }

# Avoid using Advertise & Subwidget because our contents are not
# public, plus Tk::Frame already has a 'label'
sub _subwidg {
    my ($self, $name, $widg) = @_;
    my $hash = $self->privateData->{widgets} ||= {};
    if ($widg) {
	$hash->{$name} = $widg;
    } else {
	$widg = $hash->{$name};
# XXX: Over-use of Tk::Exists here .. should use a non-existence event instead
	if ($widg && !Tk::Exists($widg)) {
	    $widg = $hash->{$name} = undef;
	}
    }
    return $widg;
}

# Remove label widget if it isn't wanted, add it if it is
# Ensure existing widgets are correctly packed.
sub _packWidgets {
    my $self = shift;
    my $labelpos = $self->labelpos;
    return if !$labelpos; # not yet configured - will call us when it is

    foreach my $name (qw(label field)) {
	my $widg = $self->_subwidg($name);
	my $key = join "_", $name, $labelpos;

	if ($key eq 'label_none') {
	    $widg->destroy if Tk::Exists($widg);
	    $self->_subwidg($name); # drop the reference, if there was one
	    next;
	}

	if (!Tk::Exists($widg)) {
	    # XXX: Check ordering of options being set ..
	    if ($name eq 'label') {
		my @font = defined $self->labelfont ? (-font => $self->labelfont) : ();
		$widg = $self->Label(-text => $self->label, @font);
		$self->_subwidg($name, $widg);
	    } else {
		next;
	    }
	}

	my $pos = { label_n => 'top',
		    label_w => 'left',
		    label_s => 'bottom',
		    label_e => 'right',
		    field_n => 'bottom',
		    field_w => 'right',
		    field_s => 'top',
		    field_e => 'left',
		    field_none => 'top',
		  }->{$key};
	$widg->pack(-side => $pos, -fill => ($name eq 'field' ? 'both' : 'none'), -expand => 1);
    }
}


=head2 setFieldAccessors(%args)

Configure the read/reset/change/completion methods for the data, but
don't mess with the data itself, its current state or mode of display.

Clears existing accessors first.

=over 4

=item -load =E<gt> CODE

Widget can call this code in scalar context to find the current value
of the saved data for this field.  CODE decides whether/when to back
to the database for a re-adopt or re-query.

Default returns undef.

=item -default =E<gt> CODE

Serves as a fall-back for C<-load> when the GUI has no current value.

If the C<-load> returns C<undef>, the default will be used to
initialise the GUI.  If this returns a defined value, it will register
as 'default' rather than 'modified'.

No default.

=item -save =E<gt> CODE

Widget will call this code with two parameters C<($old_value,
$new_value)> to save the field.

CODE should lock, check the data hasn't changed (XXX: we have no serial number here)
write & commit, re-load as for the -load CODE, then release the lock.

No default - if this is not set, the field will be read-only.

In per-field-update mode (the old way), this is both the end of a GUI
edit and the update of the database.  Return value will be used as for
-load, and if this value differs from what was saved then it is
assumed to be some canonical form and used as the fresh data.

In whole-card-update mode (the correct way), this is just the update
of the database; use C<-finish> to hook the end of the GUI edit.
Presence of C<-finish> indicates whole-card-update.  Return value is
ignored, data will be reloaded later via the C<-load> method.

=item -finish =E<gt> CODE

Will be called (one arg: the new GUI value) when the GUI has detected
a completed edit to this field, but after the field's own
C<validateGuiValue> has run - this may have changed the value.

This may be due to the user leaving the field or pressing
Enter, or some other indication that the user has lost interest in
this field.

XXX: Would be very useful to allow this code to easily modify the data (e.g. C<s/^\s+|\s+$//g>) or widget state (e.g. "data is the same, clear the modified flag")

See also C<-save>.

=item -complete =E<gt> CODE

If this is set, some form of completion is enabled for the field.

When needed (and probably frequently), the widget calls in list
context with parameters C<($text, $cursor_offset)>.

Return values should be a list of suitable replacements for the entire
string; empty list means to do nothing.

=item -click =E<gt> CODE

When the display type is 'button', this will called from the button's
Tk click command.

If it returns an empty list, nothing further will happen.

If it returns a list, that list will be passed as args to
 $self->getUpdateField->popMenu(@list)

=back

=cut

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

    my $A = {};
    foreach my $key (qw( load default save finish click complete )) {
	my $val = delete $args{"-$key"};
	if (ref($val) eq 'CODE') {
	    # anon sub supplied - ok
	    $A->{$key} = $val;
	} elsif (ref($val) eq 'ARRAY') {
	    # Further args may be appended by doCallback caller
	    my ($object, $methodName, @configArgs) = @$val;
	    die "Expected [object, methodname, args] for -$key list" unless ref($object) && !ref($methodName);
	    $A->{$key} = sub { # XXX: anon sub is an easy half-migration to proper method calls
		my @callerArgs = @_;
		return $object->$methodName(@configArgs, @callerArgs);
	    };
	} elsif (defined $val) {
	    die "Parameter -$key => $val: type not recognised";
	}
    }

    my @left = keys %args;
    die "Unknown accessor type(s) found: @left" if @left;

    die $self->debugId." is perFieldCommit\n" if ($A->{save} && !$A->{finish});
    $self->privateData->{accessors} = $A;
    $self->setFieldDisplay();
my $ev = Tk::Widget->profileBlock('setFieldAccessors/postSet');

    $self->update;
}

# Nobble the field (currently, permanently)
sub blooper {
    my ($self, $why) = @_;
    return $self->privateData->{blooped} if !defined $why;

    my $image = $self->Label(-bitmap => 'error', -fg => 'red')
      ->place(-relx => 0.5, -rely => 0.5, -anchor => 'center');
    $self->privateData->{blooped} = $image;
    warn "Disabled field ".$self->debugId.": $why\n";
    $self->update;

# undo:
#	my $old = $self->blooper;
#	$old->destroy;
#	delete $self->privateData->{blooped};
}

# Get one or many callback CODE refs
sub _getCallback {
    my ($self, @name) = @_;
    my $A = $self->privateData->{accessors};
return undef if $self->privateData->{blooped} && (@name != 1 || $name[0] ne 'load');
    return undef unless $A;
    return wantarray ? @{$A}{@name} : $A->{$name[0]};
}

sub doCallback {
    my ($self, $accessorName, @args) = @_;
    return $self->_getCallback($accessorName)->(@args);
}

sub hasCallback {
    my ($self, $name) = @_;
    die "Object method needs 1 arg" unless @_ == 2;
    return $self->_getCallback($name) ? 1 : 0;
}

sub doAccess_Load {
    my $self = shift;
    my $P = $self->privateData;

    my $seq = $self->getSeq;
    my ($oldval, $oldseq) = $self->_getValue('db');
    $self->_log('db pre-load', $seq, $oldval);

    my $newval = $self->hasCallback('load') ? $self->doCallback('load') : undef;
    # If loader returns undef, then we must load the default

    # XXX: should be using sequence number (primary key value) for database load decisions, but we have none
    if ((!defined $oldseq) && (!defined $newval)) {
	# We have no database value for initialisation
	$self->_log('db null-load', $seq, $newval);
	$self->_setValue('db', $seq, $newval);

    } elsif (defined $oldseq && !defined $newval && defined $oldval) {
	# Used to have a DB value, but it went away
	$self->_log('db post-load (value gone)', $seq, $newval);
	$self->_setValue('db', $seq, $newval);
	# Separate case 'cos some may say this is a 'modified' not a
	# 'conflict', but GT does allow data to become no longer
	# current and this would be a conflict...

    } elsif (!defined $oldseq || # no previous value - take current
	     (defined $newval xor defined $oldval) ||
	     (defined $newval && defined $oldval && $newval ne $oldval) # value changed, take new
       ) {
warn "doAccess_Load: oldval is undef on ".$self->debugId if !defined $oldval && defined $oldseq;
warn "doAccess_Load: newval is undef on ".$self->debugId if !defined $newval && defined $oldseq;
	$self->_log('db post-load', $seq, $newval);
	$self->_setValue('db', $seq, $newval);

    } else {
	$self->_log('db no-change', $seq, $oldval);
    }
}

sub canSave     { $_[0]->hasCallback('save') }

sub doAccess_Complete {
    my ($self, $cursor_pos) = @_;
    if ($self->hasCallback('complete')) {
	my @completions = $self->doCallback('complete', ${ $self->getTextRef }, $cursor_pos);
	return @completions;
    }
    return ();
}

sub _log {
    my ($self, $event, $seq, $value) = @_;
    my $lbl = $self->cget('-label');
    $event = '[undef]' unless defined $event;
    $seq = '[undef]' unless defined $seq;
    $value = '[undef]' unless defined $value;
#    my $p = $self->PathName;
#    warn "  $lbl:(ev=$event, seq=$seq, value=$value)\n"
#      if $p =~ /pIL/;
}

sub _setValue {
    my ($self, $type, $seq, $value, $gui_already_updated) = @_;
    my $old_value = $self->privateData->{"value-$type-val"};
    $self->privateData->{"value-$type-val"} = $value;
    $self->privateData->{"value-$type-seq"} = $seq;

    # Writing the GUI .. slightly messy
    if ($type eq 'gui' && defined $seq && !$gui_already_updated) {
	$value = "" unless defined $value; # e.g. undefs from not-yet-set fields
	$self->getUpdateField->set($value);
    }


    my %known_states = (# values not significant
			modified => 1, # user edit
			async_change => 1, # database conflict detected
			saved => 1, # data saved & reloaded
			loaded => 1, # data came from the database
			default => 1, # program-generated edit (modified, but not by the user)
		       );
    if ($type eq 'state') {
	warn "Using unknown state=$value on ".$self->debugId."\n" unless $known_states{$value};
	if (!defined $old_value || $value ne $old_value) {
	    $self->_updateGuiState;
	}
    }

    $self->dataSizeChange;
}

sub _getValue {
    my ($self, $type) = @_;
    my ($value, $seq) = @{ $self->privateData }{"value-$type-val", "value-$type-seq"};
}

#----------------------------------------------------------------------------
#
# Tk configure() methods

sub labelpos {
    my $self = shift;
    if (!@_) {
	# cget
	return $self->privateData->{labelPos};
    }
    my $newval = shift;

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

    die "Invalid value for -labelpos => $newval, use one of qw/n s e w none/"
      unless $newval =~ /^([nsew]|none)$/;

    $self->_packWidgets;
}

sub label {
    my $self = shift;
    return $self->privateData->{label} if !@_; # cget
    my $newval = shift;

    if (!defined $newval) {
	$self->configure(-labelpos => 'none');
    } else {
	# labelpos may remain 'none': 'label' becomes a fieldname for use by the code
	$self->privateData->{label} = $newval; # XXX: doesn't update existing widget; but now I think some some code relies on that 8-(
    }
    $self->_packWidgets;
}

sub datafont {
    my $self = shift;
    return $self->privateData->{datafont} if !@_; # cget
    my $newval = shift;

    my $font = $self->privateData->{datafont} = $newval;
    my $w = $self->getUpdateField;
    $w->configure(-font => $font) if Tk::Exists($w);
}

sub labelfont {
    my $self = shift;
    return $self->privateData->{labelfont} if !@_; # cget
    my $newval = shift;

    my $font = $self->privateData->{labelfont} = $newval;
    my $w = $self->_subwidg('label');
    $w->configure(-font => $font) if Tk::Exists($w);
}

sub fieldtype {
    my $self = shift;
    return $self->privateData->{field_type} if !@_;
    return $self->setFieldDisplay(@_);
}

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

=head2 setFieldDisplay($type) XXX: Need config opts/Class

Configure the type of widget used to display the data field.  Valid
values of $type currently

 entry (editable) L<ATR::Tk::UpdateFieldEntry>
 label (read-only) L<ATR::Tk::UpdateFieldLabel>
 date  L<ATR::Tk::UpdateFieldDate>
 button L<ATR::Tk::UpdateFieldButton>

Ensures the field is created and of the correct type, with all
necessary callbacks installed.

(Also called internally with no args, to ensure read-only changes take
effect.)

=cut

sub setFieldDisplay {
    my ($self, $type) = @_;

my $ev = Tk::Widget->profileBlock('setFieldDisplay', -UEpath => $self->PathName);
    # XXX: Detect imminent change to item containing focus: restore it or move focus to next widget

    # No args = re-do what we had last time, or do nothing
    $type ||= $self->privateData->{field_type};
    return unless $type;
#$type = 'entry' if $type eq 'date' || $type eq 'list';

    # Figure out what we want
    my $class = "ATR::Tk::UpdateField\u$type";

    $self->privateData->{field_type} = $type;

    my $method = $class;
    $method =~ s/^.*:://;
    $method =~ s/^UpdateField/UF/;

    # Ensure we have the correct widget
    my $w = $self->getUpdateField;
    if ($w && $w->isa($class)) {
	# already of the correct type
    } else {
	# Zap old one
	$w->destroy if $w;

	# Make a new one
	my @font = defined $self->datafont ? (-font => $self->datafont) : ();

	$w = $self->$method(-textvariable => $self->getTextRef,
			    @font,
			    -datamodel => $self);

	$self->_subwidg('field', $w);
	$self->_packWidgets;
    }

    # Set up callbacks + configuration

    # the widget needs to (re)configure itself when it knows what
    # the data model and accessors are
    $w->accessorsChanged;

    $self->_updateGuiState;

    return undef; # (not a shortcut to get the widget)
}


sub update { # XXX: this is a really poor choice for a method on a widget!
    my $self = shift;
    # check state table (on paper!), do operations, update display

    my ($dv, $ds) = $self->_getValue('db');
    if (!$ds) {
	# Need to load the DB
	$self->doAccess_Load; # XXX: Wrap in eval - errors here stop the processing of other widgets?
	($dv, $ds) = $self->_getValue('db');
    }

    my ($gv, $gs) = $self->_getValue('gui');
    if (!$gs && $ds) {
	# Update GUI from DB; this is a plain load
	my $seq = $self->getSeq;
	my $event = 'db2gui';
	my $state = 'loaded';
	my $newval = $dv;

	if (!defined $dv) {
	    # No -load value, try the -default
	    my $defVal = $self->hasCallback('default') ? $self->doCallback('default') : undef;
	    if (defined $defVal) {
		$state = 'default';
		$event = 'default2gui';
		$newval = $defVal;
	    } else {
		# Still no value, pretend it's a "" load
		$event = 'nodefault2gui';
		$newval = "";
	    }
	}

	$self->_log($event, $seq, $newval);
	$self->_setValue('gui', $ds, $newval); # why $ds not $seq...? don't think it matters
	$self->_setValue('state', $seq, $state);
    } elsif ($ds > $gs) {
	# Data changed behind your back
	my $seq = $self->getSeq;
	$self->_log('async_change:gui', $seq, $gv);
	$self->_log('async_change:db', $seq, $dv);
	$self->_setValue('state', $seq, 'async_change');
	# XXX: what do we _setValue('gui',... ) here?
    }

    $self->dataSizeChange;
}


=head2 checkDb

Load widget on the database side, update GUI as appropriate.

=cut

sub checkDb {
    my $self = shift;
    $self->doAccess_Load;
    $self->update;
}


=head2 clearGui

Cancel the user's changes in this widget.

=cut

sub clearGui { $_[0]->cancel } # XXX: fix _naming of private

=head2 retryDefault

Cancel any existing default value (non-user modified GUI item), reload
new.

=cut

sub retryDefault {
    my $self = shift;
    my ($state, $state_seq) = $self->_getValue('state');
    if (!defined $state || $state eq 'default' || $state eq 'loaded') {
	my $seq = $self->getSeq;
	$self->_log('retryDefault', $seq);
	$self->_setValue('gui');
	$self->_setValue('db');
	$self->update;
    }
}


#----------------------------------------------------------------------------
#
# Size control

sub ClassInit {
    my ($pkg, $mw) = @_;
    $pkg->SUPER::ClassInit($mw);

    # XXX: this deals with imposed size changes, but we need more hooks for when a UF's contents change
    $mw->bind($pkg, '<Configure>' => 'dataSizeChange');
}

# XXX: this is a monster bodge to resize this $self (isa UpdateEntry isa Frame) to what the font wants.  Ideally we just grid UpdateField widgets into an outer manager/frame and do the calculations once, without the jiggling and time delays.
sub tkSizeChange {
    my ($self, @args) = @_; # not sure how/why we get '$self' but we do

    my $uf = $self->getUpdateField;
    my @uf;
    @uf = $uf->wantFracSize if $uf;

    my $lbl_pos = $self->labelpos;
    my $lbl = $self->_subwidg('label');
    my @lbl = (0, 0);
    if ($lbl && $lbl_pos) {
	@lbl = ($lbl->reqwidth, $lbl->reqheight);
	my $lbl_ratio = 1;
	my $lbl_font = $lbl->cget('-font');
	$lbl_ratio = $lbl_font->fracRatio if $lbl_font->isa('ATR::Tk::Font');
	foreach (@lbl) { $_ *= $lbl_ratio }
    }

    my @size;
    if ($uf && $lbl_pos eq 'none') {
	# just a UF in our frame, we're free to size ourself
	@size = @uf;
    } elsif ($uf && $lbl_pos =~ /^[ns]$/) {
	# XXX: workaround for the need to put each widget in its own 'grid' cell; see imgp2785-UpdateFoo-widgets.jpg
	@size = ($uf[0] > $lbl[0] ? $uf[0] : $lbl[0],
		 $uf[1] + $lbl[1]);
    } elsif ($uf && $lbl_pos =~ /^[we]$/) {
	@size = ($uf[0] + $lbl[0],
		 $uf[1] > $lbl[1] ? $uf[1] : $lbl[1]);
    }

    if (@size) {
	$self->GeometryRequest(@size);
	# UE is currently always pack()ed inside
	$self->packPropagate(0) if $self->packPropagate;
    } else {
	# still we can't deal with all labels...
warn "can't size for ".$self->PathName unless $self->privateData->{tkSizeChange_n}++;
	$self->packPropagate(1) unless $self->packPropagate;
    }
}

# hook to ensure widget gets resized shortly after a data change XXX: this should be observer style; my state machine is a mess
sub dataSizeChange {
    my $self = shift;
    my $P = $self->privateData;

    # If timer exists, let that fire.
    # Cancelling & recreating is slightly slow and not necessary
    return if $P->{_setValue_timer};

    my $do_size = sub {
	undef $P->{_setValue_timer};
	$self->tkSizeChange if Tk::Exists($self);
    };
    if (!exists $P->{_setValue_timer}) {
	# First resize for this widget: try to do it _before_ widget
	# is drawn at its current/default size.  Can't do it now, may
	# not have all the config data.
	$P->{_setValue_timer} = $self->afterIdle($do_size);
    } else {
	$P->{_setValue_timer} = $self->after(100, $do_size);
    }
}


#----------------------------------------------------------------------------
#
# Callback wrapper methods

sub hasEdit {
    my $self = shift;
#    my ($db_value, $db_seq) = $self->_getValue('db');
#    my ($gui_value, $gui_seq) = $self->_getValue('gui');
#    return defined $gui_seq && (!defined $db_seq || $gui_seq > $db_seq);
# why did I think that was a good idea? test came from old finish() method, was OK until we had defaults
    my ($state, $state_seq) = $self->_getValue('state');
    return $state eq 'modified' || $state eq 'default';
}

sub setEdit {
    my ($self, $new_val) = @_;

    my $seq = $self->getSeq;
    $self->_setValue('gui', $seq, $new_val);
    $self->_setValue('state', $seq, 'modified');
    $self->update;
}

sub doUpdate { # XXX: $rollbackActions here? Move responsibility back to CardRow or AtrCard?
    # This is a whole-card-commit "save" operation, called inside an eval/rollback
    my $self = shift;

    # Updating unchanged fields is bad: will quietly fill the database with drivel
    die "doUpdate called on unchanged field ".$self->debugId unless $self->hasEdit;
    die "doUpdate called on modified read-only field".$self->debugId unless $self->canSave;

    my ($old_db_value, $old_db_seq) = $self->_getValue('db');
    my ($gui_value, $gui_seq) = $self->_getValue('gui');
    my $seq = $self->getSeq;
#warn "doUpdate ".$self->debugId." db($old_db_seq:$old_db_value) gui($gui_seq:$gui_value) at seq$seq\n";
    $self->_log('db pre-save', $seq, $old_db_value);
    $self->_log("doUpdate", $seq, $gui_value);
# XXX: Here's where we ought to: grab a lock, check the data is the same, commit, re-load data, release lock
# (responsibility passes to whole-card commit...)
    $self->doCallback('save', $old_db_value, $gui_value);

    return undef;
}

sub debugId {
    my $self = shift;
    my $lbl = $self->label || '[no label]';
    my $where = Tk::Exists($self) ? $self->PathName : '[gone]';
    return "UpdateEntry($lbl at $where)";
}

sub doDisplayCommit {
    my ($self) = @_;

    # Force a DB load, clear & refresh the GUI, mark as saved.
    # Similar to a 'cancel' but we have to do more work here
    my $seq = $self->getSeq;
    $self->_log("doDisplayCommit", $seq);
    $self->_setValue('db');
    $self->doAccess_Load;
    my ($dv, $ds) = $self->_getValue('db');
    $self->_setValue('gui', $ds, $dv);
    $self->_setValue('state', $ds, 'saved');

    $self->update;
}

# User finished an edit: <KeyPress-Enter> or (not per-field commit) <focusOut>
sub finish {
    my $self = shift;

    if (!$self->canSave) {
	# Happens when focus leaves a read-only entry (e.g. which used to be r/w)
#	warn "Ignoring edit-finish on read-only field ".$self->debugId."\n";
	return;
	# not-canSave fields break the other case...
    }

    # Whole-card commit: edit finish is a small callback
    my $field = $self->getUpdateField;
    my $dataProblem = $field ? $field->validateGuiValue : undef;
    my ($gui_value, $gui_seq) = $self->_getValue('gui');
    $dataProblem = $self->doCallback('finish', $gui_value)
      if !defined $dataProblem;
    if (defined $dataProblem) {
	my $debugId = $self->debugId;
	warn "Data '$gui_value' on $debugId was invalid: $dataProblem\n"; # XXX:BNS
	$field->flash;
	$field->ufCancel;
	warn "Field edit cancelled (I didn't know what else to do)\n";
# this causes trouble, including looping edit veto pairs:	    $field->afterIdle(sub { $field->focus });
    }
    # User continues editting, clicks Update later; then we get a doUpdate call

    $self->update;
    return 0;
}

sub keystroke { # XXX: Push keystroke gubbins off into UpdateField*
    # XXX: Needs to catch DB errors caused by bogus input
    my ($self, $key) = @_;

    my $e = $self->getUpdateField;
    return 1 if !$e;

    if ($e->isa('Tk::Entry')) { # completion, of a sort
	my $cursor = $e->index('insert');
	my @vals = $self->doAccess_Complete($cursor);

	if (@vals == 1) {
	    $e->delete(0, 'end'); # clear text, put in the completion (should share a prefix!)
	    $e->insert('end', $vals[0]);
	    $e->icursor($cursor);
#	$e->selectionRange($cursor, 'end'); # display selection to indicate completion
# don't set selection, breaks backspace
	}
    # else ... nothing to do; multi-choice completion not implemented,
    # this is just for auto-serial numbered text
    }

    # Check for change and update
    my ($oldval) = $self->_getValue('gui');
    my $newval = ${ $self->getTextRef };
    if (defined $newval && (!defined $oldval || $oldval ne $newval)) {
	my $seq = $self->getSeq;
	$self->_log("key=$key", $seq, $newval);
	$self->_setValue('gui', $seq, $newval, 1); # (updating from textref)
	$self->_setValue('state', $seq, 'modified');
	$self->update;
	return 0;
    } else {
	return 1;
    }
}

sub cancel {
    my ($self) = @_;

    my $seq = $self->getSeq;
    $self->_log("cancel", $seq);

    # Force update to reload both
    $self->_setValue('gui');
    $self->_setValue('db');

    $self->update;
    return 0;
}

#----------------------------------------------------------------------------
#
# Status indicator

sub _updateGuiState {
    my $self = shift;
    return unless Tk::Exists($self);

    my ($state) = $self->_getValue('state');
    return unless defined $state;

    my $field = $self->getUpdateField;
    return unless $field;

    my $normal = $field->cget('-normalcolour');

# XXX: Link to %known_states, with integrity
    my $col = { loaded => $normal,
		unmodified => $normal,
		modified => 'LightBlue',
		default => '#7916cbc6e6e9',
		saved => 'PaleGreen',
		async_change => 'red',
	      }->{$state} || 'purple';
#warn " $self: state=$state => col=$col\n";

    $field->configure(-background => $col);

    $self->dataSizeChange;
}


1;
