package ATR::Tk::CardRowMouse;

use strict;
use warnings;

use base 'ATR::Tk::CardRow';

if (eval "use ATR::Proto; 1") { # XXX: "temporary"
    warn "Loaded prototype code\n";
}

# $Id: CardRowMouse.pm,v 1.26 2005/04/18 19:12:50 mca Exp $

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

sub makeWidgets { # XXX: Make create-on-demand?  Need to do save (and therefore edit for hidden fields
    my ($self, $makeIn, @UEparams) = @_;
    my @cols = $self->columns;
    my %info = $self->fieldInfo;
    my $rowName = $self->name;
    my $widgets = $self->_widgets; # direct access hash
    foreach my $colname (@cols) {
	my ($label, $fieldType) = @{ $info{$colname} };
	die "Don't know label for col '$colname'" unless $label;
	next if $widgets->{$colname};

	my $w = $makeIn->
	  UpdateEntry(Name => (join "__", $rowName, $colname),
		      -label => $label,
		      @UEparams);
	$widgets->{$colname} = $w;
	# will be attached via show(), by a CardRow method
	$w->setFieldDisplay($fieldType);
    }
}

# Return string for mouse name on display: (for mouse being added to a
# card) it's what's currently in the GUI.  For an existing mouse, this
# is the same as the database name had from the Mouse object.
sub getVisibleMouseName {
    my $self = shift;
    my $w = $self->_widgets->{name};
    die "Can't find mouse name for ".$self->debugId unless $w;
    my $mouseName = ${ $w->getTextRef }; # XXX: Dirty private access
    return defined $mouseName && $mouseName =~ /\S/ ? $mouseName : "";
}

sub adopted     { $_[0]->{_mouse} }
sub setAdopted  { $_[0]->{_mouse} = $_[1] }

sub unadoptedName    { $_[0]->{_unadMouseName} } # irrelevant when we have an 'adopted' mouse
sub setUnadoptedName { $_[0]->{_unadMouseName} = $_[1] }

# XXX: Use 'penned' in CardRowParent
# May need to handle a collection of Penned (and then query that collection),
# but currently we only deal with the one for "now"
sub penned     { $_[0]->{_penned} }
sub setPenned  { $_[0]->{_penned} = $_[1] }

sub hasEdit {
    my $self = shift;
    my $W = $self->_widgets;
    while (my ($col, $w) = each %$W) {
	next unless $w->isa('ATR::Tk::UpdateEntry');
	return 1 if $w->hasEdit;
    }
    return 0;
}

#----------------------------------------------------------------------------
sub data_sex_load {
    my $mouse = (shift)->adopted;
    return undef if !$mouse;
    my @sex = $mouse->getSex;
    return $sex[0];# ." \[$sex[1]]";
}

sub __data_sex_fix {
    my $newval = shift;
    $newval =~ s/\s*\[[^\[\]]*\]\s*//g;
    $newval =~ s/^\s*|\s*$//g;
    return uc(substr($newval, 0, 1))
      if $newval =~ /^(male|female|not sexed|[mfn])$/i;
    return "";
}

sub data_sex_finish {
    my $self = shift;
    my $newval = shift;
    if ($self->getVisibleMouseName ne "") {
	return "Please enter M(ale), F(emale) or N(ot yet sexed)"
	  unless __data_sex_fix($newval); # XXX: data test and the error message should be in the Mouse
    } else {
	return "Please set the mouse first"
	  unless $newval eq "";
    }
    return undef; # "no problem"
}

sub data_sex_save {
    my $self = shift;
    my ($oldval, $newval) = @_;
    my $mouse = $self->adopted;
    if ($mouse) {
	$mouse->setSex(__data_sex_fix($newval));
    } else {
	my $name = $self->getVisibleMouseName;
	warn "XXX: need to set sex on new mouse $name before setting name; must wait for the creation\n";
    }
# XXX: May end up swapping the parents; reload mouse data to GUI
#$self->afterIdle(sub { foreach my $w (@parentwidg) { $w->clearGui } }); # XXX: Ick
}

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

sub data_name_load {
    my $mouse = (shift)->adopted;
    # XXX: Load for no-penned in weaning card: must decline to supply value (of load or default), in order to allow a $row->fieldsUpdate without conflict; why does a default cause a conflict? see notifyMouseNameEdit
    return $mouse ? $mouse->getMouseName : "";
}

sub data_name_finish {
    my $self = shift;
    my $newval = shift;
    my $mouse = $self->adopted;

    # Detect and ignore null-edit to the name, else we zap the edits when the user tabs through 'name' field
    # XXX: Ignoring null-edit is probably the responsibility of UpdateEntry (faster too?)
    {
	my $mouseName = $mouse ? $mouse->getMouseName : $self->unadoptedName;
	return undef if defined $mouseName && $newval eq $mouseName; # same as current mouse
    }
    $self->setUnadoptedName($newval); # may not be used later, if we find the mouse named $newval

    warn "XXX:BNS adopted mouse + reset fields without checking user edit to ".$mouse->getMouseName."\n"
      if $mouse;

    # Adopt newly chosen mouse
    $mouse = ATR::MicePE::Mouse->findByName($newval);
    $self->setAdopted($mouse); # may be undef

    # Zap edits to existing data on this row (except 'name', which changed)
    my %w = %{ $self->_widgets };
    foreach my $colname (keys %w) {
	next if $colname eq 'name';
	$w{$colname}->clearGui;
    }
    $self->notifyMouseNameEdit;

    return undef;
}

sub data_name_save {
    my $self = shift;
    my ($oldval, $newval) = @_;

    my $mouse = $self->adopted;
    if (!$mouse && $self->isa('ATR::Tk::CardRowParent')) { # XXX: Bodge to retain parent creation here - it should be in addParent(-create => 1)
	my $tryMouse = ATR::MicePE::Mouse->findByName($newval);
	if ($tryMouse) {
	    die "Program logic bug - mouse $newval should have been adopted to row already"; # Not sure about this...
	}
	# XXX: Need CardRow config for (dis)allowing null-adopt and subsequent create
	warn ">>> Will create new mouse named '$newval'\n";
	$mouse = ATR::MicePE::Mouse->createNamed($newval); # XXX:HISTORIC typo makes new mouse!
	$self->setAdopted($mouse);

	my $sex_w = $self->_widgets->{sex};
	if ($sex_w->hasEdit) {
	    $sex_w->doUpdate;
	    warn "XXX: set new-mouse parent sex late\n";
	}
    } elsif (!$mouse) {
	# mouse might be created by the save process...
    } else {
	# Check name of $mouse we have
	my $adoptedMouseName = $mouse->getMouseName;
	die "Program logic bug - expected mouse $newval to have been adopted to this row, but found $adoptedMouseName instead"
	  if $adoptedMouseName ne $newval;
    }
    $self->saveCardMouse($mouse);

    return undef;
}

sub data_name_click {
    my $self = shift;

    my $card = $self->guiCard;
    my @descr = (Name => "mousename_menu", -menuitems =>
       [
	[ Button => "Mouse editor...",
	  (ATR::Proto->can('showMouseEditor')
	   ? ( -command => [ \&ATR::Proto::showMouseEditor,
			     $card, $self->getVisibleMouseName, $self->adopted ] )
	   : (-state => 'disabled') ) ],
	[ Button => "Do something" ],
	[ Cascade => "Fate", -menuitems =>
	  [
	   [ Button => "Culled", -state => 'disabled' ],
	   [ Button => "Found dead", -state => 'disabled' ],
	   [ Button => "Used for experimentation", -state => 'disabled' ],
	  ],
	],
	[ Cascade => "Send to", -menuitems =>
	  [
	   [ Button => "New mating pair...", -state => 'disabled' ],
	   [ Separator => "" ],
	   [ Button => "New card...", -state => 'disabled' ],
	  ],
	],
	[ Separator => "" ],
	[ Cascade => "Things", -menuitems =>
	  [
	   [ Cascade => "Other things", -menuitems =>
	     [
	      [qw[Button Invert]], [qw[Button Transvert]], [qw[Button Subvert]],
	     ],
	   ],
	  ],
	],
       ]
		);

    return @descr;
}

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

sub data_geno_load {
    my $mouse = (shift)->adopted;
    return undef if !$mouse;
    my $geno = $mouse->getGenotype;
    return defined $geno ? $geno : "";
}

sub data_geno_save {
    my $mouse = (shift)->adopted;
    my ($oldval, $newval) = @_;
    $mouse->setGenotype($newval);
}

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

sub data_dob_load {
    my $mouse = (shift)->adopted;
    return undef if !$mouse;
    my $dob = $mouse->getDateBirth;
    return defined $dob ? $dob->getUI : "";
}

sub data_dob_finish {
    my $self = shift;
    my $newval = shift;
    return undef if $newval; # widget ensures it's a valid date or null
    return undef if $self->getVisibleMouseName eq "";
    return "Please set the mouse's Date of Birth"; # mandatory field...  XXX: but we can't enforce this be filled in if it's blank when the card is loaded! OK for now, but this is an example case for UE rules
}

sub data_dob_save {
    my $mouse = (shift)->adopted;
    my ($oldval, $newval) = @_;
    $mouse->setDateBirth($newval);
}

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

sub data_since_load {
    my $P = (shift)->penned;
    return $P ? $P->getStartDate->getUI : undef; # undef for blank, in case a subclass provides a default
}

sub data_until_load {
    my $P = (shift)->penned;
    my $until = $P ? $P->getEndDate : undef;
    return $until ? $until->getUI : undef;
}

sub data_since_save {
    my ($self, $oldval, $newval) = @_;
warn "XXX: for addition of a mouse, this field will have been used already...";
    $self->penned->setStartDate($newval);
}

sub data_until_save {
    my ($self, $oldval, $newval) = @_;
warn "XXX: for addition of a mouse, this field will have been used already...";
    $self->penned->setEndDate($newval);
}

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

# General data - we have no methods for these yet XXX: Scary setFreeRemark use!
my %FCREM_type = (pheno => 'Phenotype',
		  ear   => 'Earmark',
		  coat  => 'Coat',
		  dna   => 'DNAnum',
		  comm  => 'Comment');

sub data_FCREM_load {
    my $M = (shift)->adopted;
    my $remType = shift;
    return $M ? $M->getFreeRemark($remType) : undef;
}
sub data_FCREM_save {
    my ($self, $remType, $oldval, $newval) = @_;
    $self->adopted->setFreeRemark($remType, 1, $newval);
}

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

sub data_NOCHECK_finish { return undef } # "no problem"; suitable for any field that needs it

sub fieldsUpdate { # XXX: set mouse add/edit name/remove hooks - setting name on no-data is rather specific to the old matingpair parent addition
    my ($self) = @_;

    my %w = %{ $self->_widgets };

    if ($w{name}) {
	my $mouse = $self->penned;
	$w{name}->setFieldDisplay($mouse ? 'button' : 'entry');
    }

    my %accsList = $self->fieldInfo_Accessors;
    foreach my $field (keys %accsList) {
	next unless $w{$field};

	my %accs = (-finish => [ $self, 'data_NOCHECK_finish' ]); # default -finish, just makes the whole-card-commit

	foreach my $accessorName (@{ $accsList{$field} }) {
	    my $methodName = join "_", "data", $field, $accessorName;
	    if ($self->can($methodName)) {
		$accs{"-$accessorName"} = [ $self, $methodName ];
	    } elsif ($FCREM_type{$field}) {
		$accs{"-$accessorName"} = [ $self, "data_FCREM_$accessorName", $FCREM_type{$field} ];
	    } else {
		die "Can't do $methodName here (best you find out early)";
	    }
	}

	$w{$field}->setFieldAccessors(%accs);
    }

    foreach my $w (keys %w) { $w{$w}->checkDb }
}


sub getCommitOrderWidgets { # XXX: Might want different update/commit/rollback/gui-refresh orders?  Can I work them out?  Probably not worth it
    my $self = shift;
    my %widg = %{ $self->_widgets }; # copy of hash, for selective deletion
    my @widg;

    # Order-critical widgets...  'name' calls saveCardMouse, so do this
    # after setting mouse properties.
    # XXX: need to decouple mouse creation from setting the name: existing_mouse->addParent needs sex set before, but new_mouse_name->addParent should set the sex after creating the mouse and before adding the parent
    push @widg, delete $widg{name};
    # Do whatever is left (visible or not) before 'name'
    unshift @widg, values %widg;

    return grep { defined $_ } @widg;
}


#----------------------------------------------------------------------------
#
# Non-parent mouse row code; choice of being the base class for
# CardRowParent is a little arbitrary, but avoid the need for an
# abstract base class of only two concrete types.

sub saveCardMouse {
  my ($self, $mouse) = @_;
  # $mouse is the adopted mouse, or undef; for parents, could be a created mouse (old bodge)
                  warn "XXX: addMouse(-create) needs fields to set before addition, for checks(+logic?) to work"
		    if !$mouse;
                  # move create logic out to here? send field-set down to MicePE and mark saved here?
                  # field save order: putting properties on before/after adding mouse to card?
                  # time to think about the ghost ATR2GT mouse class?
                  # allow save accessors to defer until the mouse exists?
  my %mouse = ($mouse
	       ? (-mouse => $mouse)
	       : (-name => $self->getVisibleMouseName, -create => 1));
  my $penned = $self->guiCard->card->addMouse(%mouse);
  $self->setPenned($penned);
  $self->setAdopted($penned->getMouse);

  if ($mouse{-create}) {
      my $sex_w = $self->_widgets->{sex};
      if ($sex_w->hasEdit) {
	  $sex_w->doUpdate;
	  warn "XXX: set $mouse{-name} new-mouse sex too late for card checks\n";
      }
  }

  # Cardname depends on card contents, but the update routine
  # refreshes all fields so we don't have to bodge it here
}

sub notifyMouseNameEdit {
    my $self = shift;
# can't do this yet, see data_name_load comment
#    $self->guiCard->afterIdle(sub { $self->guiCard->fieldsUpdate });
}

# XXX:FEATURE  Notice columns containing all the same data and put (some of?) these read-only (or with multi-write?) in header; but have an option to restore the column if we want to edit one
sub fieldInfo {
    return (# fieldname => [ heading_text, widget_type ]
	    name  => [ 'Name',        'entry' ], # NB. overridden in fieldsUpdate
	    since => [ 'From',        'date'  ],
	    until => [ 'Until',       'date'  ],
	    sex   => [ 'Sex',         'list'  ],
	    dob   => [ 'D.O.B.',      'date'  ],
	    geno  => [ 'Geno',        'entry' ],
	    pheno => [ 'Pheno',       'entry' ],
	    ear   => [ 'Ear',         'entry' ],
	    coat  => [ "Coat",        'entry' ],
	    dna   => [ 'DNA#',        'entry' ],
	    comm  => [ 'Comm.',       'entry' ],
	   );
}

sub fieldInfo_Accessors {
    return (dob  => [qw[load finish save]],
	    geno => [qw[load save]],
	    sex  => [qw[load finish save]],
	    name => [qw[load finish save click]],
	    # XXX: click => Menu to remove mouse from card?

	    # PennedAnimal date range, mainly for debugging purposes
	    since => [qw[load save]],
	    until => [qw[load save]],

	    # Generic methods
	    pheno => [qw[load save]],
	    ear   => [qw[load save]],
	    coat  => [qw[load save]],
	    dna   => [qw[load save]],
	    comm  => [qw[load save]],
	   );
}

1;
