package ATR::Tk::UpdateHList;

use strict;
use warnings;

use base qw(Tk::Derived Tk::HList);
Tk::Widget->Construct('UpdateHList');

# $Id: UpdateHList.pm,v 1.4 2005/05/16 15:33:49 mca Exp $

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

my @PROPS = qw(data colinfo defstyle);

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

    $self->ConfigSpecs(map {( "-$_" => [qw[METHOD]] )} @PROPS );
}

# At compile time, construct methods for these properties,
# each of the form "get value // store new values and queue an update"
foreach my $property (@PROPS) {
    my $getset =
sub {
    return $_[0]->{(__PACKAGE__)}->{$property} if @_ == 1; # cget (a.s.a.p)

    my ($self, $newval) = @_;
    $self->{(__PACKAGE__)}->{$property} = $newval;
    $self->queue_refresh($property);
};
    no strict 'refs';
    *{$property} = $getset;
}


=head2 $widg-E<gt>setDisplay($dataset, $path_colId, @titles)

XXX: Currently this sets the UpdateHList display in a one-off way, there is no tracking when the data changes.

C<$dataset> is the L<ATR::Dataset> source.

C<$widg> must be configured with sufficient columns for the arguments
given.

C<$path_colId> is the colId to use for the entry path to associate
with the row.

C<@titles> contains an ordered list of HList column
headings.

colIds are as defined for C<$dataset-E<gt>get> method.

C<$hlist_column_heading> will be set on the hlist heading.  Pass by
reference.

To generate HList entry-paths from C<$rowId> (number),

 $dataset->new_colmap($dataset->name."+paths", hpath => sub {
			  my ($me, $rowId) = @_;
			  return "row$rowId";
		      })
  ->setDisplay($dataset, 'hpath', @titlemap);

=cut

sub setDisplay {
    my ($self, $dataset, $path_colId, @titlemap) = @_;
    my $tk_path = $self->PathName;

    $self->data($dataset);

    # Convert old args to Dataset
    my @tmp;
    while (@titlemap) {
	my ($colId, $title) = splice @titlemap, 0, 2;
	push @tmp, [ $colId, $title ];
    }
    push @tmp, ([ $path_colId, "_ENTRYPATH" ],
		[ undef,  "_DATA" ]);
    my $oldraw_colinfo = ATR::Dataset->new_sqlfetch
       ("rawColinfo\@$tk_path",
	[qw[ value_dcol hlist_title ]], \@tmp);

    $self->colinfo($oldraw_colinfo); # will be converted (colmap wrapper) in _refresh

    $self->refresh('setDisplay');
}

sub queue_refresh {
    my ($self, $why) = @_;
    $self->privateData->{queue_refresh} ||=
      $self->afterIdle([ $self, 'refresh' ]);
    $self->privateData->{refresh_why}->{$why} ++;
}

sub refresh {
    my ($self, $why) = @_;
    $why ||= 'refresh';
    $self->privateData->{refresh_why}->{$why} ++;
    $self->_refresh;
}


# colinfo:  Dataset rows are used in order, mapped to HList columns
#   hlist_title = text for the header		(or '_ENTRYPATH' or '_DATA')
#   value_dcol = colId within 'data', giving text for the HList entry item
#   style_dcol = colId within 'data', giving Tk::ItemStyle		[optional]
#   head_style = Tk::ItemStyle for the heading				[optional]

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

    # Ensure all necessary columns are available on colinfo+data

    my $data = $self->data();
    my $colinfo = $self->colinfo();

    # Bodge in older type column?
    if ( !$colinfo->hasColid('style_dcol') &&
	 $data    ->hasColid('ditemstyle')) {
	my $added = $colinfo->new_colmap
	  ($colinfo->name."+ditemstyle",
	   style_dcol => sub { "ditemstyle" });
	$self->colinfo($added);
	$colinfo = $added;
    }


### unfinished
#    # Tk::Balloon setup for hlist
#    my $balloon_colId = (@titlemap % 2 ? pop @titlemap : undef);
#    if ($balloon_colId && !$HPD->{balloon}) {
#	my $var = "default message";
#	$HPD->{balloon} = ATR::Util::tlBalloon($self);
#	$HPD->{ref} = \$var;
#	$HPD->{balloon}->attach($self, -msg => $HPD->{ref},
#				-postcommand => [ \&__hlist_balloon_post, $self ]);
#    }


    # Get info about columns collection
    my ($hpath_dcol, $pathdata_dcol);
    my @display_colinfo_rowId;
    foreach my $c ($colinfo->rowList) {
	my ($title, $valcol) = $colinfo->getcols($c, qw(hlist_title value_dcol));

	if ($title eq '_ENTRYPATH') { # XXX: Untidiness...  not sure where path_dcol belongs .. but they're in the way here
	    $hpath_dcol = $valcol;
	} elsif ($title eq '_DATA') {
	    $pathdata_dcol = $valcol;
	} else {
	    push @display_colinfo_rowId, $c;
	}
    }

    # Configure columns
    $self->_set_header( [ $colinfo->getrows('hlist_title', @display_colinfo_rowId) ],
			$colinfo->hasColid('head_style')
			? [ $colinfo->getrows('head_style', @display_colinfo_rowId) ]
			: undef
		      );

    my @style_dcol = ($colinfo->hasColid('style_dcol')
		      ? $colinfo->getrows('style_dcol', @display_colinfo_rowId)
		      : ());
    my @value_dcol =    $colinfo->getrows('value_dcol', @display_colinfo_rowId);


#    my @got_paths;
#    {
#	# Stack-based entrypath recursion; preserve row ordering
#	my @fetch = $self->info('children');
#	while (@fetch) {
#	    my $path = shift @fetch;
#	    unshift @fetch, $self->info('children', $path);
#	    push @got_paths, $path;
#	}
#    }

#    # Delete the entries we know we're going to put back,
#    # ensures they're in the correct order with respect to each other.
#    for my $rowId ($data->rowList) {
#	my $hlistPath = $data->get($hpath_dcol, $rowId);
#	$self->delete('entry', $hlistPath)
#	  if $self->info('exists', $hlistPath);
#    }
# XXX: neater way to preserve order would be with add(-at / -after ), or better still have multiple Datasets for original and appended data...?

### could re-use paths and update, but this is easier:
    $self->delete('all');

    # Put the rows and their data
    for my $rowId ($data->rowList) {
	my $hlistPath = $data->get($hpath_dcol, $rowId);
	my @value = $data->getcols($rowId, @value_dcol);
	my @style = $data->getcols($rowId, @style_dcol);

	$self->add($hlistPath);
	$self->_set_row($hlistPath, \@value, \@style);
    }

    # Clear pending refresh
    my %why = %{ delete $self->privateData->{refresh_why} };
    my $timer = delete $self->privateData->{queue_refresh};
    $timer->cancel if $timer;
}


sub _set_header {
    my ($self, $titles, $styles) = @_;
    # $styles or its array contents may be undef: results in undef -style option
    my $hlist_cols = $self->cget('-columns');

    for (my $c=0; $c<$hlist_cols; $c++) {
	my $has_hdr = $self->header('exists', $c);
	if (!defined $titles->[$c]) {
	    # don't want a columnhead here
	    $self->header('delete', $c) if $has_hdr;
	    next;
	}
	$self->header( ($has_hdr
			? ('configure', $c)
			: ('create', $c, -itemtype => 'text') ),
		       -style => $styles->[$c],
		       -text  => $titles->[$c]);
    }
}

sub _set_row {
    my ($self, $path, $values, $styles) = @_;
    # $styles or its array contents may be undef: results in undef -style option
    my $hlist_cols = $self->cget('-columns');

    for (my $c=0; $c<$hlist_cols; $c++) {
	my $has_item = $self->itemExists($path, $c);
	if (!defined $values->[$c]) {
	    # don't want a value here
	    $self->item('delete', $path, $c) if $has_item;
	    next;
	}
	$self->item( ($has_item
		      ? ('configure', $path, $c)
		      : ('create',    $path, $c, -itemtype => 'text') ),
		     -style => $styles->[$c],
		     -text => $values->[$c]);
    }
}


1;
