package ATR::Tk::ColonyEd;

use strict;
use warnings;
use Carp;

use base qw(Tk::Derived Tk::Frame);
use Tk::Checkbutton;
use Tk::DialogBox;
use Tk::ItemStyle;
Tk::Widget->Construct('ColonyEd');

use ATR::Dataset;
use ATR::Util;
use ATR::Date;
use ATR::Tk::UpdateHList;

=head1 NAME

ATR::Tk::ColonyEd - colony information display and modification widget

=head1 DESCRIPTION

Initially, just a colony viewer.

=cut

# $Id: ColonyEd.pm,v 1.33 2005/05/17 16:50:37 mca Exp $

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

sub Populate {
    my ($self, $args) = @_;
    $self->SUPER::Populate($args);
    my $f = $self->getFont;
    my $P = $self->privateData;

# Button area
    $self->Advertise('operators',
		     $self->Frame(Name => "buttons_f") # config by optdb
		     ->pack(-side => 'bottom', -fill => 'x')
		    );
    my $ops = $self->Subwidget('operators');
    my $upd_b = $ops->Button(-text => 'Update',
			     -command => [ $self, '_tk_Update' ],
			     -state => 'disabled', # (until recommission)
			     -font => $f)->pack(-side => 'right');
    $ops->Button(-text => 'Close / discard',
		 -font => $f,
		 -command => [ $self, 'op_close' ])->pack(-side => 'right');
    $ops->Checkbutton(-image => $self->getImage('nopencil'),
		      -selectimage => $self->getImage('pencil'),
		      -background => 'red',
		      -selectcolor => 'green',
		      -activebackground => 'yellow',
		      -state => 'disabled', # XXX:LOCK not implemented
		      -padx => 2,
		      -indicator => 0)->pack(-side => 'left')
			->select;
    $self->Advertise(upd_b => $upd_b);
    # XXX: ops & close are probably standard for widgets implementing decommission...? but not UE

# Main scrolled area, in which we put "sections", each a Frame
    my $scr_f = $self->Scrolled('Pane', Name => 'outerscroll_f', -scrollbars => 'ose', -sticky => 'nsew')
      ->pack(-fill => 'both', -expand => 1);
    my $scr_ff = $scr_f->Subwidget('pane')->slave; # the Pane's Frame, managed & delegated but doesn't get grid*configure methods
    $self->Advertise('data_p' => $scr_f);
    $self->Advertise('data_f' => $scr_ff);


    my $col_f = $self->put_section('col', '0,0');
    @{$P}{qw{col_w stf_w lci_w phe_w}} = ({}, {}, {}, {});
    my $stf_f = $self->put_section('stf', '1,0');
    my $lci_f = $self->put_section('lci', '0-1,1');
    my $phe_f = $self->put_section('phe', '0-1,2');
    $scr_ff->gridRowconfigure(3, -weight => 1);

    $scr_ff->gridColumnconfigure(1, -weight => 1);

    # Frame colours are set during post-Populate configure; we override after that
    $self->afterIdle
      (sub {
	   $scr_f->configure(-bg => 'grey');
       });

    $self->_makeWidg
      ($col_f, $P->{col_w},
       # [ gridpos, widg_name => "widg title" ],
       [qw[ 0-1;0nw LBL       ], 'Colony information' ],
       [qw[   0;1w  colony       ], 'Name' ],
       [qw[   0;2w  col_descr    ], 'Description' ],
       [qw[   0;3w  cardcol      ], 'Card colour' ], # row match colour_patch below
       [qw[ 0-1;4w  purpose      ], 'Purpose' ],
       [qw[ 0-1;5w  mutclass     ], 'HO Mutant Class'],
       [qw[ 0-1;6w  notes        ], 'Notes' ],
       [qw[ 0-1;7w  room         ], 'Room (last seen in)' ],
       [qw[ 0-1;8w  bkg_col      ], 'Background strain' ]);
    $self->_makeWidg
      ($stf_f, $P->{stf_w},
       [qw[ 0-1;0nw LBL       ], 'Staff and licences' ],
       [qw[ 0-1;3w  ppl          ], 'Project licence' ]);
    $self->_makeWidg
      ($lci_f, $P->{lci_w},
       [qw[ 0-2;0nw LBL       ], 'Loci of interest' ]);
    $self->_makeWidg
      ($phe_f, $P->{phe_w},
       [qw[ 0-2;0nw LBL       ], 'Phenotypes relevant to colony' ]);

# Extra widgets
    $P->{col_w}->{colour_patch} = $col_f->Frame(Name => 'colour_patch', -width => 64)
      ->grid(__gridArgs('1,1-3nse'));

    $P->{stf_w}->{tpr} = $stf_f->Scrolled
      ('UpdateHList',
       Name => 'scr_tpr',
       -scrollbars => 'osoe',
       -height => 7,
       -font => $f,
       -columns => 6, -header => 1)
      ->grid(__gridArgs('0+3,1ew'), -padx => 4, -pady => 4);
    $P->{stf_w}->{add_role_b} = $stf_f->Button
      (Name => 'add_role_b',
       -text => 'Add person...',
       -font => $f,
       -command => [ $self, '_tk_addColonyRole' ])
	->grid(__gridArgs('2-3,0se'));

    $P->{phe_w}->{add_pheno_b} = $phe_f->Button
      (Name => 'add_pheno_b',
       -text => 'Add phenotype...',
       -font => $f,
       -state => 'disabled')
      # XXX: need "un-add" (aka. revert/cancel edit) on the menu; new phenotype group; groups of phenotypes; add new phenotype to group
      ->grid(__gridArgs('2,0se'));
    $P->{phe_w}->{phenos} = $phe_f->Scrolled
      ('UpdateHList',
       Name => 'scr_phenos',
       -font => $f,
       -scrollbars => 'osoe',
       -height => 8,
       -columns => 6, -header => 1)
	->grid(__gridArgs("0-2,1-2nsew"));
    $phe_f->gridColumnconfigure(1, -weight => 1);

    $col_f->gridColumnconfigure(5, -weight => 1); # space stuff over to the left
    $stf_f->gridColumnconfigure(2, -weight => 1); # extra width for the hlist
    $stf_f->gridRowconfigure(2, -weight => 1); # spare space to the bottom

    $P->{lci_w}->{add_loc_b} = $lci_f->Button
      (Name => 'add_loc_b',
       -text => 'Add locus...',
       -font => $f,
       -state => 'disabled')->grid(__gridArgs('1,0se'));
    $lci_f->gridRowconfigure(0, -weight => 1);
    $lci_f->gridColumnconfigure(0, -weight => 1);
    $lci_f->gridColumnconfigure(1, -weight => 1);

    # Hook the Update button
    $P->{stf_w}->{tpr}->privateData->{updater} = \&hlistdata__tpr__save;
    $P->{phe_w}->{phenos}->privateData->{updater} = \&hlistdata__phenos__save;

# Data setup
    my %ed_args;
    $ed_args{-colonyName} = delete $args->{-colonyName};

    $self->bind('<Destroy>' => [ $self, 'decommission' ]);
    $self->recommission(%ed_args);

#$self->after(3000, [$self, 'decommission']);
}


sub atrmainScroll { # callback for ATR::Tk::Main
    my ($self, $units) = @_;
    $self->Subwidget('data_p')->yview('scroll', $units, 'units');
}


sub show_locus_f {
    my ($self, $key) = @_;
    my $P = $self->privateData;

    my $lci_w = $P->{lci_w};
    my $lci_f = $self->Subwidget('lci_f');

    my $loc_f_exist = $P->{loc_f_exist} ||= {}; # key = $key, value = grid-row or undef
    my $loc_f_grid  = $P->{loc_f_grid}  ||= [ 'LBL' ]; # pos = grid-row, value = $key
    $key = "auto".(scalar keys %$loc_f_exist) if !defined $key;

    my $loc_f = $lci_w->{$key};
    if (!$loc_f) {
	# Construct frame
	$loc_f = $lci_f->Frame(Name => $key, -class => 'Locus');
	$lci_w->{$key} = $loc_f;
	$loc_f_exist->{$key} = undef;
	# Populate widgets
	my $f = $self->getFont;
	$self->_makeWidg
	  ($loc_f, $lci_w,
	   # [ gridpos, widg_name => "widg title" ],
	   [ '0-1;1w', "$key.name",     "Name"],
	   [ '0-1;2w', "$key.longname", "Long name"],
	   [ '0-1;3w', "$key.symb",     "Official symbol"]);
	$lci_w->{"$key.add_geno_b"} = $loc_f->Button
	  (Name => 'add_geno_b',
	   -text => 'Add genotype...',
	   -font => $f,
	   -state => 'disabled')->grid(__gridArgs('1,4e'));
	$lci_w->{"$key.add_pheno_b"} = $loc_f->Button
	  (Name => 'add_pheno_b',
	   -text => 'Add phenotype...',
	   -font => $f,
	   -state => 'disabled')->grid(__gridArgs('1,5e'));
	$lci_w->{"$key.genos"} = $loc_f->Scrolled
	  ('UpdateHList',
	   Name => 'scr_genos',
	   -font => $f,
	   -scrollbars => 'osoe',
	   -height => 5,
	   -width => 20,
	   -columns => 2,
	   -header => 1)->grid(__gridArgs('2,0-5nsew'));
	$loc_f->gridColumnconfigure(2, -weight => 1);

	# Hook the Update button
	my $HP = $lci_w->{"$key.genos"}->privateData;
	$HP->{updater} = \&hlistdata__locus__save;
	$HP->{locus_key} = $key;
    }

    if (!$loc_f_exist->{$key}) {
	# Not already on show, stick it on the end
	my $row = @$loc_f_grid; # the next available row
	$loc_f_exist->{$key} = $row;
	$loc_f_grid->[$row] = $key;
	$loc_f->grid(-row => $row, -column => 0,
		     #-row => int(($row-1)/2)+1, -column => (($row-1) % 2),
		     -sticky => 'nsew', -padx => 4, -pady => 2);
    }

    return wantarray ? ($loc_f, $key) : $loc_f;
}

sub visible_locus_f { # return list of $key for in-use frames
    my $self = shift;
    my $P = $self->privateData;
    my $loc_f_exist = $P->{loc_f_exist} ||= {}; # key = $key, value = grid-row or undef
    my $loc_f_grid  = $P->{loc_f_grid}  ||= [ 'LBL' ]; # pos = grid-row, value = $key

    my @in_use;
    foreach my $key (keys %$loc_f_exist) {
	push @in_use, $key if defined $loc_f_exist->{$key};
    }

    return @in_use;
}

sub get_locus_fields { # return list of pairs of (fieldname => UpdateEntry || UpdateHList) for $key
    my ($self, $key) = @_;
    my $P = $self->privateData;
    my $lci_w = $P->{lci_w};
    return (name => $lci_w->{"$key.name"},
	    longname => $lci_w->{"$key.longname"},
	    symb => $lci_w->{"$key.symb"},
	    genos => $lci_w->{"$key.genos"},
	   );
}

sub hide_locus_f { # hide all of them
    my $self = shift;
    my $P = $self->privateData;
    my $loc_f_exist = $P->{loc_f_exist} ||= {}; # key = $key, value = grid-row or undef
    my $loc_f_grid  = $P->{loc_f_grid}  ||= [ 'LBL' ]; # pos = grid-row, value = $key
    my $lci_w = $P->{lci_w};
    foreach my $key (keys %$loc_f_exist) {
	my $old_row = $loc_f_exist->{$key};
	next unless defined $old_row;
	# Update data structures
	$loc_f_exist->{$key} = undef; # exists, but no longer mapped
	$loc_f_grid->[$old_row] = undef;
	# Update GUI
	$lci_w->{"$key.genos"}->delete('all');
	$lci_w->{$key}->gridForget; # loc_f
    }
    # remove undefs off the grid list, 'cos its size is used for generating row numbers
    while (@$loc_f_grid && !defined $loc_f_grid->[-1]) { splice(@$loc_f_grid, -1, 1) }
}

sub put_section {
    my ($self, $secname, $gridpos) = @_;
    my $sec_f = $self->Subwidget($secname."_f");
    if (!$sec_f) {
	$sec_f = $self->Subwidget('data_p')->Frame
	  (Name => $secname, -class => 'Section');
	$self->Advertise($secname."_f" => $sec_f);
    }

    my %grid = (-padx => 3, -pady => 3, __gridArgs($gridpos), -sticky => 'nsew');
    $sec_f->grid(%grid);
#    my @stripes = ('#e0c9ff', '#c9e0ff', '#c9ffe0');
#    $sec_f->configure(-background => $stripes[($grid{-row} + $grid{-column}) % @stripes]);
    return $sec_f;
}

sub __gridArgs($) {
    my $gridpos = shift;
    my %grid;
    @grid{qw{-column -row -sticky}} = ($gridpos =~ /^(\d+(?:[-+]\d+)?)[,;](\d+(?:[-+]\d+)?)([nsew]*)$/);
    die "Can't read gridpos '$gridpos'" unless defined $grid{-row};
    foreach my $key (qw{-column -row}) {
	next unless $grid{$key} =~ s/([-+])(\d+)$//;
	my ($symb, $num) = ($1, $2);
	my $start = $grid{$key};
	my $span = 1;
	if ($symb eq '-') {
	    die "Can't make gridpos '$gridpos' do $key:$start-$num"
	      if $num < $start;
	    $span = $num - $start + 1;
	} else {
	    die "Can't make gridpos '$gridpos' do $key:$start+$num"
	      if $num < 1;
	    $span = $num;
	}
	$grid{$key."span"} = $span unless $span == 1;
    }
    return %grid;
}

sub _makeWidg {
    my ($self, $dest_w, $dest_h, @widg) = @_;
    my $f = $self->getFont;
    for (my $i=0; $i<@widg; $i++) {
	my ($gridpos, $name, $title) = @{ $widg[$i] };
	my $W;

	if ($name =~ /^LBL/) {
	    $W = $dest_w->Label(-class => 'Heading', -font => $f, -text => $title);
	} else {
	    $W = $dest_w->UpdateEntry
	      (Name => $name,
	       -labelfont => $f,
	       -datafont => $f,
	       -label => $title,
	       -labelpos => 'w');
	}
	$dest_h->{$name} = $W;
	$W->grid(__gridArgs($gridpos));
    }
}


sub op_close { # XXX: Does no modified-data checks  XXX:DUP ATR::Tk::AtrCard->op_close
    my $self = shift;
    # Can't destroy this card here, because it will break the callback we're in
    $self->toplevel->closeItemDelayed($self);
}

sub getFont {
    my $self = shift;
    die "Takes no args" if @_;
    return $self->toplevel->furnitureFont;
}

sub getImage {
    my ($self, $name) = @_;
    my $tl = $self->toplevel;
    my $tPi = $tl->privateData->{images} ||= {};
    return $tPi->{$name} if defined $tPi->{$name};
    my $path = "ATR/Tk/$name.xpm";
    if (!exists $tPi->{$name}) {
	my $fn = Tk::findINC($path);
	$tPi->{$name} = $self->toplevel->Pixmap(-file => $fn)
	  if defined $fn;
    }
    die "Image '$path' not found in INC" if !defined $tPi->{$name};
    return $tPi->{$name};
}

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

    my $upd_b = $self->Subwidget('upd_b');
    $upd_b->configure(-state => 'disabled') if Tk::Exists($upd_b); # precaution against bad DB update

    my $P = $self->privateData;
    delete $P->{data};

    foreach my $w ($self->getAllFields) {
	next unless Tk::Exists($w);
# don't do this, they have no data:	$w->clearGui if $w->can('clearGui');
	$w->delete('all') if $w->isa('ATR::Tk::UpdateHList'); # recommission's setDisplay calls do this too,
	# but closing the app with populated HList seems to cause coredump(?!)
    }

    $self->hide_locus_f();
}

sub recommission {
    my ($self, %args) = @_;
    die "Creating colony info is not yet possible (no -colonyName given)"
      unless defined $args{-colonyName};
    my $colName = delete $args{-colonyName};
    my ($hdr, $rows);
    my $D = $self->D;

# Colony
    ($rows, $hdr) = $self->_getAll('getColony', [$colName]);
    die "Creating colony info is not yet possible (colony '$colName' not found)"
      unless @$rows == 1;
    $D->{col_info} = ATR::Dataset->new_colmap
      ("col_info/dicts:$colName",
       ATR::Dataset->new_sqlfetch("col_info:$colName", $hdr, $rows),
       # dynamic joins with CARD_COLOUR_DICT, MUTATION_CLASS_DICT
       clr_name     => __gencol__dict_join(card_colour => listColours => id_colour => 'name'),
       mutclass_gui => __gencol__dict_join(mutclass_id => listMutantClasses => id_mutant_class => 'gui_descr'),
### Was like this:
#       # manual dynamic join with CARD_COLOUR_DICT, MUTATION_CLASS_DICT
#       clr_name => sub {
#	   my ($me, $rowId) = @_;
#	   my $id = $me->get('card_colour', $rowId);
#	   return $self->getDict('listColours', 'id_colour')->get('name', $id);
#       },
#       mutclass_gui => sub { # convert ID into name/description
#	   my ($me, $rowId) = @_;
#	   my $id = $me->get('mutclass_id', $rowId);
#	   return $self->getDict('listMutantClasses', 'id_mutant_class')->get('gui_descr', $id);
#       },
      );
    my $id_colony = $D->{col_info}->get('id_colony', 0);

# Project Licence - expect only one, ignore multiple is_current's
    ($rows, $hdr) = $self->_getAll('getColonyProjectLicence', [$id_colony]);
    $D->{lic_info} = ATR::Dataset->new_colmap
      ("lic_info/dicts:$colName",
       ATR::Dataset->new_sqlfetch("lic_info:$colName", $hdr, $rows),
       # dynamic joins to LICENCE, LICENCE_TYPE_DICT
       name          => __gencol__dict_join(id_licence => listProjectLicences => id_licence => 'name'),
       description   => __gencol__dict_join(id_licence => listProjectLicences => id_licence => 'description'),
       lictype_name  => __gencol__dict_join(id_licence => listProjectLicences => id_licence => 'lictype_name'),
       lictype_descr => __gencol__dict_join(id_licence => listProjectLicences => id_licence => 'lictype_descr'),
      );

# Colony-linked roles
    $self->hlistdata__tpr__load();

# Phenotype
    ($rows, $hdr) = $self->_getAll('getColonyPhenos', [ $id_colony ]);
    $D->{phe_d} = ATR::Dataset->new_sqlfetch('phe_d', $hdr, $rows);

# Loci => genotypes => pheno_genos
    ($rows, $hdr) = $self->_getAll('getColonyLoci', [ $id_colony ]);
    $D->{lci_d} = ATR::Dataset->new_colmap
      ('lci_d',
       # colmapped object contains original data,
       ATR::Dataset->new_sqlfetch('lci_d0', $hdr, $rows),
       # plus two columns of scalar ref (i.e. easily writable even with only a 'get' method)
       ATR::Dataset->new_sqlfetch('lci_d_refs', [qw[ref_gui_key ref_geno_subq]],
				  [map { __blankrefsRow(2) } @$rows]),
       # Add a clever column which will run a sub-query and cache the resulting Dataset
       # XXX: this is a bit scary like this...  code it up properly if it's convenient to use
       get_geno => sub {
	   my ($me, $rowId) = @_;
	   my $cache = $me->get('ref_geno_subq', $rowId);
	   return $$cache ||= do {
	       my $id_locus = $me->get('id_locus', $rowId);
	       my ($rows, $hdr) = $self->_getAll('getLocusGenotypes4Colony', [ $id_locus, $id_colony ]);
	       ATR::Dataset->new_sqlfetch("getLocusGenotypes4Colony:$colName=$id_colony,$id_locus", $hdr, $rows);
	   };
       });


# Link & reset fields
    $self->fields_link;
    foreach my $w ($self->getAllFields) {
	$w->clearGui if $w->can('clearGui');
    }

    # XXX: Link colour widget to the card_colour of the moment; a change-event observer on the value would be better
    $self->_tk_setCardColour();

    # Last of all, allow DB update
    $self->Subwidget('upd_b')->configure(-state => 'normal');
}

# returns list of $num SCALARrefs, populated with undef
sub __blankrefsRow {
    my $num = shift;
    my @row;
    while (@row < $num) {
	my $var;
	push @row, \$var;
    }
    return \@row;
}

sub getAllFields { # XXX: No particular order; UEs and UHLists together
    my $self = shift;
    my @all;
    foreach my $h (@{$self->privateData}{qw{col_w phe_w stf_w lci_w}}) {
	push @all, grep { $_->isa('ATR::Tk::UpdateEntry') } values %$h;
    }
    my $P = $self->privateData;
    my @hlist = ($P->{stf_w}->{tpr},
		 $P->{phe_w}->{phenos});
    foreach my $locus_key ($self->visible_locus_f) {
	my %fields = $self->get_locus_fields($locus_key);
	push @all, values %fields;
    }
    return (@all, @hlist);
}

sub D { $_[0]->privateData->{data} ||= {} }

# Tunnel through to the bio-db-handle   XXX: There should be a BioTables subclass of some sort
# my $rows = ATR::BioTables->_getAll('FooQuery', [1, 2, 3]);
#   returns ($rows, $fields) for @$rows and the fieldname list
sub _getAll {
    my ($self, $localQueryname, $params) = @_;
    confess "Need 2 args on class method" unless @_ == 3;
    my $queryname = 'ATR/ColonyEd::'.$localQueryname;
    return (scalar ATR::BioTables->_getAll($queryname, $params),
	    scalar ATR::BioTables->_getSE2->getSthInfo($queryname, 'NAME_lc', ATR::BioTables->_getDbh));
}
sub _do {
    my ($self, $localQueryname, $params, $quiet) = @_;
    confess "Need 3 args on class method"
      if @_ != 4
	|| ref($quiet); # not a dbh!

    return ATR::BioTables->_do('ATR/ColonyEd::'.$localQueryname, $params, $quiet);
}


=head2 getDict($queryName, $optionalIndex)

Class or object method for loading and indexing a dictionary.

Without C<$optionalIndex>, returns the (cached) Dataset for that
query.

With C<$optionalIndex> set to a number, returns a (cached)
hash-rowmapped Dataset built
from the list of rows, with key = (value of field as indexed), value =
(reference of the appropriate row).

No warnings if there are conflicts/overwritten keys, rows will just be
overwritten in no particular order.  Standard warning if the key is
undef/null.  No warnings if you index on a column which doesn't exist.

XXX: In some cases an ARRAY would be better than a HASH, but the code shouldn't be figuring this out.

XXX: Could accept third arg for value of indexed column to return the value of - no need for getting the whole hash

=cut

my %CLASS_GLOBAL_DICTS;
sub getDict {
    my ($class, $dictQuery, $idxCol) = @_;

    # Caching place.
    #   key = $dictQuery, value = [ $scanTime, $dataset, hashed-col0, hashed-col1, ... ]
    # The hashed columns are filled in as required.
#    my $D = $self->privateData->{dicts} ||= {};
    my $D = \%CLASS_GLOBAL_DICTS;

    my ($cache, $dataset);

    if ($D->{$dictQuery}) {
	$cache = $D->{$dictQuery};
	my ($when, $c_dataset, @hashed) = @$cache;
	my $now = time();
	if ($now - $when < 120) { # 2 minutes' cache, from DB fetch
	    # We have some data, return whatever is appropriate
	    $dataset = $c_dataset;
	} # else cache will be replaced
    }

    if (!defined $dataset) {
	# Do the fetch
	my ($rows, $hdr) = $class->_getAll($dictQuery, []);
	$dataset = ATR::Dataset->new_sqlfetch("dict:$dictQuery", $hdr, $rows);
	# Map in extra columns?
	my %pluscols =
	  (# dictionaries with some added GUI description columns
	   listBackgroundStrains => [ gui_descr => \&__listBackgroundStrains__gui_descr ],
	   listMutantClasses => [ gui_descr => \&__listMutantClasses__gui_descr ],
	   listAvailableRoles => [ fullname => \&__listAvailableRoles__fullname,
				   contact => \&__listAvailableRoles__contact,
				   teamrole => \&__listAvailableRoles__teamrole,
				   gone => \&__listAvailableRoles__gone,
				 ],
	   # dictionaries with dynamic joins to other dictionaries
	   listProjectLicences => [ lictype_name  => __gencol__dict_join(id_type => listLicenceTypes => id_type => 'name'),
				    lictype_descr => __gencol__dict_join(id_type => listLicenceTypes => id_type => 'description'),
				  ],
	  );
	$dataset = $dataset->new_colmap
	  ("$dictQuery:pluscols", @{ $pluscols{$dictQuery} })
	    if $pluscols{$dictQuery};
	$cache = $D->{$dictQuery} = [ time(), $dataset ];
    }

    return $dataset if !defined $idxCol; # They want all the rows

    my $colnum = $dataset->colid2num($idxCol);
    my $colname = $dataset->colnum2name($colnum);
    return $cache->[$colnum + 2]
      ||= $dataset->map_colhash($dataset->name.":$colname", $colnum);
}


sub fields_link {
    my $self = shift;

    my $D = $self->D;
    my $P = $self->privateData;
    my $col_info = $D->{col_info};

    my @link = (# [ gui_group, gui_fieldname, col_info_column, 'type',
		#   {optional UE accessor override hash} ],
		[qw[ col_w colony      name    label ]],
# not displayed: id_name id_colony
		[qw[ col_w col_descr   c_description entry ]],
		[qw[ col_w purpose     purpose entry ]],
		[qw[ col_w notes       notes   entry ]],
		[qw[ col_w mutclass    mutclass_gui button ]],

		[qw[ col_w bkg_col     id_background_strain button ]],

		[qw[ col_w room     room  entry ]],
		[qw[ col_w cardcol  clr_name button ]], # XXX: tie to id?

	       );
    foreach my $L (@link) {
	my ($group_w, $n_gui, $n_data, $type, $extra) = @$L;
	my $w  = $P->{$group_w} || die "Can't find widget group '$group_w'";
	my $ue = $w->{$n_gui}   || die "Can't do fields_link for n_gui=$n_gui";

	$ue->setFieldDisplay($type);

	# Find 'data__foo__click' methods
	$extra = $self->_accessors_add($n_gui, $extra);
	$col_info->setUpdateEntry($n_data, 0, $ue, $extra);
    }

# PPL  XXX: combine into loop above
    {
	my $ue = $P->{stf_w}->{ppl};
	$ue->setFieldDisplay('button');
	$D->{lic_info}->setUpdateEntry('name', 0,
				       $ue,
				       $self->_accessors_add(ppl => undef));
	# XXX: PPL field needs: click,save methods + slave fields to decipher to the 19b's for mating + weaning
    }

# "people involved"
    $P->{stf_w}->{tpr}->setDisplay($D->{stf_d},
			    'id_colony_role',
			    fullname => 'Name',
			    reason_name => 'Reason',
			    from_date => 'Since',
			    gone_until => 'Until',
			    contact => 'Contact info',
			    teamrole => 'Team',
			    );

# Phenotypes
    $D->{phe_d2} = ATR::Dataset->new_colmap
      (phe_d2 => $self->D->{phe_d},
       genolist => sub { "(not calculated)" },
      );

    $P->{phe_w}->{phenos}->setDisplay($D->{phe_d2},
			     'id_colony_phenotype',
			     grp_name => 'Group', # grp_descr is displayed nowhere
			     pheno_name => 'Name',
			     pheno_descr => 'Description',
			     pheno_remark => 'Remark',
			     genolist => '(Genotypes)');

# Set up each locus
    my $lci_d = $D->{lci_d};
    for (my $r=0; $r<($lci_d->rowCount); $r++) {
	my $guikey_ref = $lci_d->get('ref_gui_key', $r);
	$$guikey_ref ||= $self->show_locus_f("Row$r"); # XXX: name it by rownum? or stash any old ref? could stash in an object-tied Dataset and do the join as necessary (lazypop style) .. would need to allow rowcount mismatch on colmap (fitting for a dynamic-rowcount set)

	my %w = map {( $_ => $P->{lci_w}->{"Row$r.$_"} )} qw(name longname symb genos);
	my $locusRownum = $r; # make a new lexical; $r remains bound and moves on

	$w{name}->setFieldDisplay('label'); # could be editable, but this may encourage misguided edits
	$lci_d->setUpdateEntry('name', $locusRownum, $w{name},
			       $self->_accessors_add('lci_name', undef, $r));

	$w{longname}->setFieldDisplay('entry');
	$lci_d->setUpdateEntry('long_name', $locusRownum, $w{longname},
			       $self->_accessors_add('lci_longname', undef, $r));

	$w{symb}->setFieldDisplay('entry'); # RTF/complex
	$lci_d->setUpdateEntry('symbol', $locusRownum, $w{symb},
			      $self->_accessors_add('lci_symb', undef, $r));

	my $geno_d = $lci_d->get('get_geno', $locusRownum); # a linked sub-query Dataset
	my $tmp = $geno_d->new_colmap
	  (($geno_d->name)."+",
	   phenocol => sub {
	       my ($me, $rowId2) = @_;
	       my %info = $me->getcolshash($rowId2, qw(id_phenotype phenogrp_name pheno_name)); # don't fetch self!
	       return "(none associated)" unless defined $info{id_phenotype};
	       return "$info{phenogrp_name}: $info{pheno_name}";
	   });
# XXX: extend hlist dumper to recurse on Dataset object, the provide data hierarchy to original plan
	$w{genos}->setDisplay($tmp,
			 'id_locus_genotype',
			 genotype => 'Genotype',
			 phenocol => 'Phenotype');
    }

}


sub idColony {
    my $self = shift;
    my $data = $self->D->{col_info};
    return $data->get('id_colony', 0);
}

sub _accessors_add {
    my ($self, $ue_name, $hashref, @args) = @_;
    $hashref ||= {};

    foreach my $accessor (qw(click load finish save)) {
	next if exists $hashref->{"-$accessor"};
	$hashref->{"-$accessor"} = $self->_accessor_find($ue_name, $accessor, @args);
    }
    $hashref->{-finish} ||= \&data__NOCHECK__finish if $hashref->{-save};
    return $hashref;
}

sub _accessor_find {
    my ($self, $ue_name, $access_mode, @args) = @_;
    my $method = join "__", "data", $ue_name, $access_mode;
    return [ $self, $method, @args ] if $self->can($method);
}


sub data__NOCHECK__finish { undef }

sub _tk_setField {
    my ($self, $ue, $value) = @_;
    if (!defined $value) {
	$ue->clearGui;
    } else {
	$ue->setEdit($value);
    }
}


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

sub data__lci_longname__save {
    my ($self, $rowId, $oldval, $newval) = @_;
    my $data = $self->D->{lci_d};
    my $id_locus = $data->get('id_locus', $rowId);

    $self->_do('setLocus__long_name', [$newval, $id_locus], 0);
    $data->set('long_name', $rowId, $newval);
}

sub data__lci_symb__save {
    my ($self, $rowId, $oldval, $newval) = @_;
    my $data = $self->D->{lci_d};
    my $id_locus = $data->get('id_locus', $rowId);

    $self->_do('setLocus__genesym', [$newval, $id_locus], 0);
    $data->set('symbol', $rowId, $newval);
}


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

sub data__cardcol__click {
    my $self = shift;
    my $clr_dict = $self->getDict('listColours');
    my @colours;
    foreach my $row ($clr_dict->rowList) {
	my ($id, $name, $rgb) = $clr_dict->getcols($row, 'id_colour', 'name', 'rgb');
	push @colours, [ Button => $name, # XXX: Should be radiobutton with current item set
			 -foreground => 'black',
			 -background => "#$rgb",
			 -activeforeground => "#$rgb",
			 -activebackground => 'black',
			 -command => [ $self, '_tk_setCardColour', $name ] ];
    }
    my $is_mod = $self->privateData->{col_w}->{cardcol}->hasEdit;
    my @menu =
      (
       [ Button => 'Reset to original value',
	 -state => ($is_mod ? 'normal' : 'disabled'),
	 -command => [ $self, _tk_setCardColour => undef ] ],
       [ Separator => "" ],
       @colours,
       [ Separator => "" ],
       [ Button => 'Add new colour...', -state => 'disabled' ], # XXX: needed?
      );
    return (Name => 'cardcol', -menuitems => \@menu);
}

sub data__cardcol__save {
    my ($self, $oldval, $newval) = @_;
    my $data = $self->D->{col_info};
    my $id_colony = $data->get('id_colony', 0);

    my $id = $self->getDict('listColours', 'name')->get('id_colour', $newval);
    $self->_do('setColony__card_colour', [ $id, $id_colony ], 0);
    $data->set('card_colour', 0, $id);
}

sub _tk_setCardColour {
    my ($self, $colour_name) = @_;
    my $col_w = $self->privateData->{col_w};
    my $ue = $col_w->{cardcol};

    # Call without a colour_name to just update the colour-patch
    $self->_tk_setField($ue, $colour_name) if @_ > 1;

    # Update the colour patch with GUI-value
    $colour_name = $ue->getUpdateField->get;
    my $rgb = $self->getDict('listColours', 1)->get('rgb', $colour_name);
    # XXX: Check $widget->visual for suitable colour rendering
    $col_w->{colour_patch}->configure
      (-borderwidth => 1, -relief => 'raised',
       -background => "#$rgb");
}

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

sub __listBackgroundStrains__gui_descr { # a CODE column for colmap
    my ($dataset, $rowId) = @_;
# XXX: need a bogus row where "primary_key IS NULL": return "n/a" if !defined $id_bkg;

    my ($id_bkg, $bkg_c_rmk, $bkg_col_descr, $bkg_col_name) = $dataset->getcols
      ($rowId, qw(id_background_strain c_remark c_description name));

    my $descr;
    if (defined $bkg_c_rmk) {
	$descr = $bkg_c_rmk;
    } elsif (defined $bkg_col_descr) {
	$descr = $bkg_col_descr;
    } else {
	$descr = "Background #$id_bkg";
    }

    if (defined $bkg_col_name) {
	$descr .= " ($bkg_col_name)";
    } else {
	$descr .= " [no colony]";
    }

    return $descr;
}

sub data__bkg_col__click {
    my $self = shift;
    my $bkg_dict = $self->getDict('listBackgroundStrains');
    my $col_w = $self->privateData->{col_w};
    my $ue = $col_w->{bkg_col};
    my @bg;
    foreach my $row ($bkg_dict->rowList) {
	my $descr = $bkg_dict->get('gui_descr', $row);
	push @bg, [ Button => $descr,  # XXX: Should be radiobutton with current item set
		    # XXX: could set -background if we wanted to look up the colony
		    -command => [ $self, '_tk_setField', $ue, $descr ] ];
    }
    # The 'undef' row isn't in listBackgroundStrains, add it separately
    push @bg, [ Button => 'n/a',
		-command => [ $self, '_tk_setField', $ue, "n/a" ] ];

    my $id_bkg_DB = $self->D->{col_info}->get('id_background_strain', 0);
    my $descr_GUI = $ue->getUpdateField->get;
    my $bkg_col_GUI =
      ($descr_GUI eq 'n/a'
       ? undef
       : $self->getDict('listBackgroundStrains', 'gui_descr')->get('name', $descr_GUI));
    my $descr_DB =
      (defined $id_bkg_DB
       ? $self->getDict('listBackgroundStrains', 'id_background_strain')->get('gui_descr', $id_bkg_DB)
       : 'n/a');

    my @menu =
      (
       ( defined $bkg_col_GUI
	 ? [ Button => "Show colony record ($bkg_col_GUI)...",
	     -command => sub { $self->toplevel->ShowColony($bkg_col_GUI) } ]
	 : [ Button => "Show: no further data", -state => 'disabled' ] ),
       [ Separator => "" ],
       @bg,
       [ Separator => "" ],
       [ Button => "Reset to '$descr_DB'",
	 -state => ($ue->hasEdit ? 'normal' : 'disabled'),
	 -command => [ $self, '_tk_setField', $ue, undef ] ],
      );
    return (Name => 'bkgstr', -menuitems => \@menu);
}

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

    my $ue = $self->privateData->{col_w}->{bkg_col};
    my $data = $self->D->{col_info};
    my $id = $data->get('id_background_strain', 0);
    my $gui_descr = (defined $id
		     ? $self->getDict('listBackgroundStrains', 0)->get('gui_descr', $id)
		     : "n/a");
    return $gui_descr;
}

sub data__bkg_col__save {
    my ($self, $oldval, $newval) = @_;
    my $data = $self->D->{col_info};
    my $id_colony = $data->get('id_colony', 0);

    my $id =
      ($newval eq 'n/a'
       ? undef
       : $self->getDict('listBackgroundStrains', 'gui_descr')->get('id_background_strain', $newval));

    $self->_do('setColony__id_background_strain', [ $id, $id_colony ], 0);
    $data->set('id_background_strain', 0, $id);
}

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

sub __listMutantClasses__gui_descr { # a CODE column for colmap
    my ($dataset, $rowId) = @_;
    my ($name, $description) = $dataset->getcols($rowId, qw(name description));
    return (defined $description ? "$name ($description)" : $name);
}

sub data__mutclass__click {
    my $self = shift;
    my $mutc_dict = $self->getDict('listMutantClasses');
    my @mutc;
    my $col_w = $self->privateData->{col_w};
    my $ue = $col_w->{mutclass};
    foreach my $row ($mutc_dict->rowList) {
	my ($gui_descr, $name) = $mutc_dict->getcols
	  ($row, qw(gui_descr name));
	push @mutc, [ Button => $name, # XXX: Should be radiobutton with current item set
		      -command => [ $self, '_tk_setField', $ue, $gui_descr ] ];
    }
    my @menu =
      (
       [ Button => 'Reset to original value', # XXX: Show the old value; disable when not modified
	 -state => ($ue->hasEdit ? 'normal' : 'disabled'),
	 -command => [ $self, '_tk_setField', $ue ],
       ],
       [ Separator => "" ],
       @mutc,
      );
    return (Name => 'mutclass', -menuitems => \@menu);
}

sub data__mutclass__save {
    my ($self, $oldval, $newval) = @_;
    my $data = $self->D->{col_info};
    my $id_colony = $self->idColony;

    my $id = $self->getDict('listMutantClasses', 'gui_descr')->get('id_mutant_class', $newval);
    $self->_do('setColony__id_mutant_class', [ $id, $id_colony ], 0);
    $data->set('mutclass_id', 0, $id);
}

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

# Compile up a bunch of identical subs with names/fields as in the hash
# XXX: A proper automatic linkage would be a better solution
my %savers = ( data__col_descr__save => 'c_description',
	       data__purpose__save => 'purpose',
	       data__room__save => 'room',
	       data__notes__save => 'notes',
	     );
while (my ($subname, $fieldname) = each %savers) {
    my $saver =
sub {
    my ($self, $oldval, $newval) = @_;
    my $data = $self->D->{col_info};
    my $id_colony = $data->get('id_colony', 0);

    $self->_do("setColony__$fieldname", [ $newval, $id_colony ], 0);
    $data->set($fieldname, 0, $newval);
};
    no strict 'refs';
    *{$subname} = $saver;
}

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

sub _tk_addColonyRole {
    my $self = shift;

    # Get new person info
    my @ids = $self->getRoleReason;
    return if !@ids; # cancelled
    if (grep {!defined} @ids) {
	# "OK" button without a complete selection
	warn "Please select from both lists\n";
	return;
    }

    my ($id_role, $id_reason) = @ids;

    # XXX: big bodge coming up
    my $new_serial = ++$self->privateData->{NEW_SERIAL};
    my $raw = $self->D->{stf_d_raw};
    $raw->append_row({ id_colony_role => "NEW_$new_serial", # currently the HList path
		       id_role   => $id_role,
		       id_reason => $id_reason,
		       status_field => 'modified',
		       from_date_gt => ATR::Date->now->getGT,
		       to_date_gt   => undef });

    my $hlist = $self->privateData->{stf_w}->{tpr};
    $hlist->refresh;
    $hlist->update; # update() before see() allows scrollbars to appear if necessary [bug workaround?]
    $hlist->see("NEW_$new_serial");
}

sub hlistdata__tpr__save {
    my ($self, $hlist) = @_;
    my $id_colony = $self->idColony;

    my $raw = $self->D->{stf_d_raw};
    my @changed;
    foreach my $rowId ($raw->rowList) {
	my $rowKey = $raw->get('id_colony_role', $rowId);
	if ($rowKey =~ /^NEW_/) {
	    my ($id_role, $id_reason, $from, $to) = $raw->getcols($rowId, qw(id_role id_reason from_date to_date));
	    my $id_cr = ($self->_getAll('addColonyRole_seq', [])) [0]->[0]->[0];

	    $self->_do('addColonyRole', [ $id_cr, $id_colony, $id_role, $id_reason, $from, $to ], 0);
	    push @changed, $id_cr;
	}
    }

    # Refresh TPR HList data whether we changed it or not
    return sub {
	$self->hlistdata__tpr__load($hlist); # Get new values ($id_cr above) and correct date formats

	# Set 'saved' state on anything we wrote
	my $tmp; # Index by id_colony_role when needed
	foreach my $id_cr (@changed) {
	    $tmp ||= $self->D->{stf_d_raw}->map_colhash('tmp_stf_d_raw', 'id_colony_role');
	    $tmp->set('status_field', $id_cr, 'saved');
	}

	$hlist->refresh;
    };
}


sub hlistdata__tpr__load {
    my ($self, $hlist) = @_; # hlist may not be available, from some places?
    my $id_colony = $self->idColony;
    my $D = $self->D;

    my ($rows, $hdr) = $self->_getAll('getColonyRole', [ $id_colony ]);

    if ($D->{stf_d_raw}) {
	# We already have all the mapping stuff, just refresh the data
	$D->{stf_d_raw}->replace_rows($rows);
	return;
    }

    $D->{stf_d_raw} = ATR::Dataset->new_sqlfetch("colony_role:$id_colony", $hdr, $rows);

    $D->{stf_d} = ATR::Dataset->new_colmap
      ("colony_role/dicts:$id_colony",
       $D->{stf_d_raw},
       # dynamic join with listAvailableRoles, XXX: this needs to autopop, else joins to newly granted roles may break the ColonyEd instance
       fullname => __gencol__dict_join(id_role => listAvailableRoles => id_role => 'fullname'),
       contact  => __gencol__dict_join(id_role => listAvailableRoles => id_role => 'contact'),
       teamrole => __gencol__dict_join(id_role => listAvailableRoles => id_role => 'teamrole'),
       # listRoleReasons
       reason_name => __gencol__dict_join(id_reason => listRoleReasons => id_reason => 'name'),

       # plus GUI transformations
       gone_until => sub {
	   my ($me, $rowId) = @_;
	   my $id = $me->get('id_role', $rowId);
	   my $until = $me->get('to_date_gt', $rowId);
	   return $until if defined $until;
	   return $self->getDict('listAvailableRoles', 'id_role')->get('gone', $id);
       },
       ditemstyle => sub {
	   my ($me, $rowId) = @_;
	   my $state = $me->get('status_field', $rowId);
	   my $bg_clr = { loaded => '#d9d9d9',
			  modified => 'LightBlue',
			  default => '#7916cbc6e6e9',
			  saved => 'PaleGreen',
			  async_change => 'red',
			}->{$state} || 'purple';
	   return $self->privateData->{ditemstyle_bg}->{$bg_clr} ||= do {
	       $self->ItemStyle('text', -background => $bg_clr, -font => $self->getFont);
	   };
       },
       from_date => __gencol__date_map('from_date_gt'),
       to_date   => __gencol__date_map('to_date_gt'),
      );
}


# Generate and return curried functions for colmap'ing:
sub __gencol__date_map { # GT --> UI date format
    my $srcColId = shift;
    return sub {
	my ($me, $rowId) = @_;
	my $gt = $me->get($srcColId, $rowId);
	return undef if !defined $gt;
	return ATR::Date->newGT($gt)->getUI;
    };
}

sub __gencol__dict_join { # dynamic join
    my ($src_colId, $dictName, $dict_keyCol, $dict_srcCol) = @_;
    return sub {
	my ($me, $rowId) = @_;
	my $id = $me->get($src_colId, $rowId);
	return __PACKAGE__->getDict($dictName, $dict_keyCol)->get($dict_srcCol, $id);
    };
}

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

sub hlistdata__phenos__save { warn "cannot yet save phenotype additions"; return () }

sub hlistdata__locus__save { warn "cannot yet save locus genotypes"; return () }

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

sub _tk_Update { # XXX:DUP see AtrCard->op_update
    my ($self) = @_;

    my $rollbackActions = [];
    my @commitActions;

    my $prob;
    my @allFields = $self->getAllFields;
    my @need_doDisplayCommit;
    $prob = ($@ || '[unknown problem]') unless eval {
	# cautious with $@ because Tk:catch is strange
	my $when = ATR::Date->now; # will be needed for some daterange starts or ends

	foreach my $field (@allFields) {
# XXX: Log commit field or context: will need this info for any bug report!
	    die "Tried to update with absent Tk field '$field'" unless Tk::Exists($field);
	    if ($field->isa('ATR::Tk::UpdateEntry')) {
		if ($field->hasEdit) {
		    push @$rollbackActions, sub {
			die "preserving your edits on rollback is not yot implemented";
		    };
		    $field->doUpdate;
		    push @need_doDisplayCommit, $field;
		}
		next;
	    }

	    if (($field->isa('ATR::Tk::UpdateHList') ||
		 $field->Subwidget('scrolled')->isa('ATR::Tk::UpdateHList')) && $field->privateData->{updater}) {
		my ($up, $roll) = @{ $field->privateData }{qw{ updater rollback }};
		push @$rollbackActions, sub {
		    die "preserving your edits on rollback is not yot implemented";
		};
		push @commitActions, $up->($self, $field); # a primitive form of doUpdate()
		next;
	    }

	    die "Can't update with unknown field type '$field' at ".$field->PathName;
	}
	1;
    };

    if (!$prob) {
	# debug menu sets commit/rollback mode
	my $result = main::doCommit();
	$prob = "debug mode rollback" if !defined $result;
    }

    my $guiRefreshProb; # refresh is for commit or rollback

    if ($prob) {
	ATR::MicePE->rollbackAll("error");
	warn "Update failed: $prob"; # XXX:USRTHROW we would need more detail, and a catcher; string-joined exception loses blessing
	warn "Changes were NOT saved (database rollback)\n";

	# Try to restore the GUI model to pre-update state
	$guiRefreshProb = ($@ || '[unknown problem]') unless eval {
	    foreach my $action (@$rollbackActions) {
		$action->();
	    }
	    # $self->_fieldsUpdate; # an AtrCard-ism
	    1;
	};
    } else {
	# Commit OK, ensure fields are marked as saved
	warn "info: Updated OK\n";
	$guiRefreshProb = ($@ || '[unknown problem]') unless eval {
#	    # Rebuild the card with new data; it should preserve/reuse the UE fields
#	    $self->_fieldsUpdate;
	    my %commitFields;
	    @commitFields{@need_doDisplayCommit} = ();
	    # Mark saved fields as saved, force reload of the others
	    foreach my $w (@allFields) {
		next unless $w->isa('ATR::Tk::UpdateEntry');
		if (exists $commitFields{$w}) {
		    $w->doDisplayCommit;
		} else {
		    $w->clearGui;
		}
	    }

	    # Update other fields
	    foreach my $act (@commitActions) {
		$act->();
	    }

	    1;
	};
    }

    if ($guiRefreshProb) {
	warn "Reloading screen to keep it up to date: $guiRefreshProb";
# XXX: Dirty card refresh (throw away data, including failed user edits and reload), prevents the commited-ok (green) markers showing
	my $colname = $self->D->{col_info}->get('name', 0);
	$self->decommission;
	$self->recommission(-colonyName => $colname);
    }

#    warn "XXX: Other GUI cards not updated!\n"; # XXX: Display confirmation of change?  invalidate all objects anyway?

}


#============================================================================
#
# Helper transient dialog for choosing (ID_ROLE, ID_REASON) pair

sub getRoleReason {
    my $self = shift;

    # Get/make the instance of the DialogBox
    my $TL = $self->toplevel;
    my $DB = $TL->privateData->{getRoleReason_dialogbox} ||= do {
	my $db = $TL->DialogBox(Name => 'col_getrolereason',
				-title => "Select person association", -buttons => [qw[OK Cancel]]);
	my $f = $self->getFont;
	my @lbl = map {
	    $db->add('Label', -class => 'Heading', -font => $f, -text => $_)
	      ->pack(-side => 'top', -anchor => 'w') }
	  ("Select person, team and role:",
	   "Select reason for association with colony:");

	my $tpr    = $db->add('Scrolled', 'UpdateHList',
			      Name => 'scr_tpr',
			      -scrollbars => 'osoe', -font => $f, -columns => 4, -header => 1)
	  ->pack(-side => 'top', -fill => 'both', -after => $lbl[0], -expand => 1);

	my $reason = $db->add('Scrolled', 'UpdateHList',
			      Name => 'scr_reason',
			      -scrollbars => 'osoe', -font => $f, -columns => 2, -header => 1)
	  ->pack(-side => 'top', -fill => 'both');
#	$reason->bind('<Click-1>' => $enable_ok);

#	my $get_result = sub {
#	    return (scalar $tpr->info('selection'),
#		    scalar $reason->info('selection'));
#	};
#	$enable_ok = sub {
#	    my @vals = $get_result->();
#	    my $invalid = grep {!defined} @vals;
#	    $db->Subwidget('B_OK')->configure(-state => $invalid ? 'disabled' : 'normal');
#	};

	$db->Advertise(tpr => $tpr);
	$db->Advertise(reason => $reason);
	$db;
    };

    # (Re-)populate HLists

    my ($tpr, $reason) = map { $DB->Subwidget($_) } qw(tpr reason);
    foreach my $w ($tpr, $reason) {
	$w->delete('all');
    }
    $tpr->setDisplay($self->getDict('listAvailableRoles'),
						   'id_role',
						   email => 'Email',
						   fullname => 'Name',
						   gone => 'Current?',
						   teamrole => 'Team',
						  );


    $reason->setDisplay($self->getDict('listRoleReasons'),
						  'id_reason',
						  name => 'Reason',
						  description => 'Description');

    # Set current user as default
    {
	my $id_role = ATR::MiceSubPE->getIdRole;
	$tpr->selectionClear;
	$tpr->selectionSet($id_role);
	$tpr->anchorSet($id_role);
	$tpr->see($id_role);
    }
#    $enable_ok->(); # or rather, disable it

    my $ok = ('OK' eq $DB->Show);
    return () unless $ok;

    my ($id_role, $id_reason) = (scalar $tpr->info('selection'),
				 scalar $reason->info('selection'));

    return ($id_role, $id_reason);
}

sub __listAvailableRoles__fullname {
    my ($dataset, $rowId) = @_;
    my ($fore, $sur) = $dataset->getcols($rowId, qw(forename surname));
    return join " ", $fore, $sur;
}

sub __listAvailableRoles__contact {
    my ($me, $rowId) = @_;
    my @info = $me->getcols($rowId, qw(email phone room));
    return join "/", grep {defined} @info;
}

sub __listAvailableRoles__teamrole {
    my ($me, $rowId) = @_;
    my ($team, $role) = $me->getcols($rowId, qw(teamname roletype));
    return "t$team ($role)";
}

sub __listAvailableRoles__gone {
    my ($me, $rowId) = @_;
    my ($iscurr_p, $iscurr_tpr) = $me->getcols($rowId, qw(iscurr_p iscurr_tpr));
    return "has left" if !$iscurr_p;
    return "left team" if !$iscurr_tpr;
    return "";
}

1;
