#
# This module offers a multicolumn-listbox for perl/Tk, which can be 
# used with records.
# Interface is nearly the same as for native Listbox, with the 
# difference, that insert() expects a Hash-parameter and get returns 
# an array of hashes.
# 
# 		this script is written by ...: geronimo at vdrportal dot de
# 
# COPYRIGHT:	(c) 2005-2006 Creative Commons by-nc-sa
#					some rights reserved. For details on copyright see:
#					http://creativecommons.org/licenses/by-nc-sa
#
# DISCLAIMER:	NO WARANTY AT ALL. Use at your own risk.
#
# vi: ts=3
#
package RecordListbox;
use strict;
use Carp qw(carp croak);
use Tk::Listbox;
use Tk::Scrollbar;
use Tk::ROText;
use Tk::Frame;
use Tk::Label;

sub populate {
	my $self = shift;

	while(my $vn = shift){
		SWITCH: for($vn) { 
			/^-columns$/		and do { my $arg = shift;
												croak($vn.' has invalid type. Expected an Array!') if not ref($arg) eq 'ARRAY';
												$self->{$vn} = $arg;	  
												last SWITCH;
											 };
			/^-headers$/		and do { my $arg = shift;
												croak($vn.' has invalid type. Expected an Array!') if not ref($arg) eq 'ARRAY';
												$self->{$vn} = $arg;	  
												last SWITCH;
											 };
			/^-selectmode$/	and do { $self->{$vn} = shift; last SWITCH; };
			/^-header$/			and do { $self->{$vn} = shift; last SWITCH; };
			/^-width$/			and do { $self->{$vn} = shift; last SWITCH; };
			/^-height$/			and do { $self->{$vn} = shift; last SWITCH; };
			croak('unknown parameter: '.$vn); 
			}
		}
}

sub rlbDummy {
   return 0;
}

sub createWidgets {
	my $self = shift;
	my $mx   = $#{$self->{-columns}};
	my $t    = $self->{-parent}->Scrolled('ROText', -width=>500, -relief=>'flat', -scrollbars=>'os', -wrap=>'none');
		
	for my $i (0..$mx){
		my $f = $t->Frame();

		if($self->{-header}){
			my $text = $self->{'-headers'}[$i];

			$self->{-lbheaders}[$i] = $f->Label(-text=>$text, -relief=>'raised', -bd=>1)->pack(-side=>'top', -fill=>'x');
			}
		my $list = $f->Listbox(-exportselection=>0
							 		, -width=>ref($self->{-width})?$self->{-width}[$i]:$self->{-width}
									, -takefocus=>1
									, -height=>$self->{-height}
									, -selectmode=>$self->{-selectmode});
		$list->bind('<<ListboxSelect>>', [\&select, $self]);
		$list->pack(-side=>'left', -expand=>1, -fill=>'both');
		$self->{-listboxes}[$i] = $list;
		$t->windowCreate('end', -window=>$f);
		}
	my $f = $self->{-parent}->Frame()->pack(-side=>'right', -fill=>'y', -expand=>1);

	$f->Label(-text=>' ', -relief=>'flat')->pack(-side=>'top');
	my $vscroll = $f->Scrollbar(-takefocus=>0);

	$vscroll->configure(-command=>sub{foreach my $list (@{$self->{-listboxes}}){$list->yview(@_);}});
	$vscroll->pack(-side=>'right', -fill=>'y');
	foreach my $list (@{$self->{-listboxes}}){
		$list->configure(-yscrollcommand=>[\&yscroll, $self, $vscroll, $list]); 	  
		}
	$self->{'-scrolled'} = $t;
	$t->configure(-state=>'disabled', -insertofftime=>0, -cursor=>'left_ptr');
   $t->menu(undef);
   $t->bind('<Button-3>', \&rlbDummy);
   $t->pack(-expand=>1, -fill=>'both');
}

sub new {
	my $class = shift;
	my $parent = shift;
	my $self  = {
		-columns    => undef	  
	,  -headers    => []			  
	,  -parent     => $parent
	,  -selectmode => 'single'
	,  -width      => 20
	,  -height     => 20
	,  -header     => 1
	,  -listboxes  => []
	,  -lbheaders  => []
	,  -scrolled   => undef
	};
	bless($self, $class);
	$self->populate(@_);
	croak('need array of columns!') if not defined($self->{-columns}) or ref($self->{-columns}) != 'ARRAY';
	$self->createWidgets();
	
	return $self;
}

sub select {
	my $w = shift;
	my $self = shift;
	my @selection  = $w->curselection();

	foreach my $list (@{$self->{-listboxes}}){
		next if $list eq $w;
		$list->selectionClear(0, 'end');
		foreach (@selection){ $list->selectionSet($_); }
		}
}

sub yscroll {
	my $self=shift;	  
	my($sb, $scrolled, @args) = @_;

	$sb->set(@args);

	my($top,$bottom) = $scrolled->yview();
	foreach my $list (@{$self->{-listboxes}}){
		$list->yviewMoveto($top);	  
		}
}

sub bind {
	my $self = shift;
	my @args = @_;

	foreach (@{$self->{-listboxes}}){ $_->bind(@args);	}
}

sub refresh {
	my $self = shift;
	my $height = 0;
	my $headers = [];
	
	while(my $arg = shift){ 
		if($arg eq '-height'){ $height = shift; }
		elsif($arg eq '-headers'){ $headers = shift;	}	
		else{ shift; }
		}
	if($height){
		foreach (@{$self->{'-listboxes'}}){
			$_->configure(-height=>$height);	  
			}
		}
	if($headers and ref($headers) eq 'ARRAY'){
		my $i = 0;
		my $mx   = $#{$self->{-columns}};

		for my $i (0..$mx){
			my $l = $self->{-lbheaders}[$i];	  
			my $text = $self->{'-headers'}[$i];

			$l->configure(-text=>$text);
			}
		}
}

sub curselection {
	my $self = shift;

	return $self->{-listboxes}[0]->curselection();
}

sub selectionClear {
	my $self = shift;
	my @args = @_;

	foreach (@{$self->{-listboxes}}){
		$_->selectionClear(@args);
		}
}

sub selectionSet {
	my $self = shift;	  
	my @args = @_;

	foreach (@{$self->{-listboxes}}){
		$_->selectionSet(@args);
		}
}

sub see {
	my $self = shift;	  
	my @args = @_;

	foreach (@{$self->{-listboxes}}){
		$_->see(@args);
		}
}

sub get {
	my $self = shift;
	my $first = shift;
	my $last = shift;
	my $dRef;
	my @rv;

	$first = $#{$self->{-columns}} if $first eq 'end';
	$last = $first if not defined($last);

	for my $cursel ($first .. $last){
		my $rec;
		
		foreach my $i (0.. $#{$self->{-columns}}){
			if($self->{-columns}[$i] =~ /\//){
				my @refParts = split(/\//, $self->{-columns}[$i]);	  
				my $last = pop(@refParts);		  

				$dRef = $rec;
				foreach (@refParts){ $dRef = $dRef->{$_};	}  
				$dRef = \$dRef->{$last};
				}
			else{ $dRef = \$rec->{$self->{-columns}[$i]}; }
			$$dRef = $self->{-listboxes}[$i]->get($cursel);	  
			}
		push(@rv, $rec);
		}
	return @rv;
}

sub parent {
	my $self = shift;
	
	return $self->{-listboxes}[0]->parent;	  
}

sub insert {
	my $self = shift;
	my $where = shift;
	my $rec = shift;	
	my $i = 0;
	my $dRef;

	foreach my $list (@{$self->{-listboxes}}){
		if($self->{-columns}[$i] =~ /\//){
			my @refParts = split(/\//, $self->{-columns}[$i]);	  

			$dRef = $rec;
			foreach (@refParts){ $dRef = $dRef->{$_};	}
			}
		else{
			$dRef = $rec->{$self->{-columns}[$i]};	  
			}
		$list->insert($where, $dRef);
		$i++;
		}
}

sub delete {
	my $self = shift;
	my $from = shift;
	my $to = shift;

	foreach (@{$self->{-listboxes}}){ $_->delete($from, $to); }
}

1;
