view release on metacpan or  search on metacpan

lib/Tk/DHList_v1.pm  view on Meta::CPAN

######################################## SOH ###########################################
## Function : Additional Tk Class for Listbox-type HList with Data per Item, Sorting
##
## Copyright (c) 2002-2005 Michael Krause. All rights reserved.
## This program is free software; you can redistribute it and/or modify it
## under the same terms as Perl itself.
##
## History  : V1.00	10-Dec-2002 	Class adopted from ExtListbox. MK
##            V1.01 10-Jan-2003 	Added -databackground(color). MK
##            V1.02 19-Jan-2004 	Added numeric sorting for column 2. MK
##            V1.1  13-May-2005 	Added missing data for sorting in column 2. MK
##            V1.2  23-Oct-2008 	Bugfix: Deleting the first entry messed the reverse func. MK
##
######################################## EOH ###########################################
package Tk::DHList_v1;

##############################################
### Use
##############################################
#use Tk::HList;
use Tk::HListplus;
use Tk::ItemStyle;
use Tk qw(Ev);

use strict;
use Carp;

use vars qw ($VERSION);
$VERSION = '1.2';

#use base qw (Tk::Derived Tk::HList);
use base qw (Tk::Derived Tk::HListplus);

########################################################################
Construct Tk::Widget 'DHList_v1';

#---------------------------------------------
# internal Setup function
#---------------------------------------------
sub ClassInit
{
    my ($class, $window) = @_;

    $class->SUPER::ClassInit($window);

	# Note these keyboard-Keys are only usable, if the widget gets 'focus'
	$window->bind ($class, '<Control-Key-bracketleft>', [\&viewtype, 'withdata']);
	$window->bind ($class, '<Control-Key-bracketright>', [\&viewtype, 'normal']);
	# Update the view after mapping
	$window->bind ($class, '<Map>', \&map_cb);
}

#---------------------------------------------
# internal Setup function
#---------------------------------------------
sub CreateArgs
{
    my ($class, $window, $args) = @_;
	
	# Necessarily Patch Columns
	my %args;	
	(%args) = ( -columns => '2') unless defined $args->{-columns};
    ($class->SUPER::CreateArgs($window, $args), %args);
}

#---------------------------------------------
# internal Setup function
#---------------------------------------------
sub Populate
{
    my ($this, $args) = @_;		

	my $data_background = delete $args->{-databackground};
	$data_background = $this->cget ('-background') unless defined $data_background;
	my $style = delete $args->{-datastyle};
	$style = $this->toplevel->ItemStyle ('text' ,
							-anchor => 'e',
							-background => $data_background,
	) unless defined $style;

	# Check whether we want numeric sorting
	$this->{m_numeric_primary_sort}   = delete $args->{-numeric_primary_sort} || 0;
	$this->{m_numeric_secondary_sort} = delete $args->{-numeric_secondary_sort} || 0;
	
	# Reroute any size_call_back
	my $sizecmd = delete $args->{-sizecmd};
	$sizecmd = sub { return 1 } unless defined $sizecmd;
	$args->{-sizecmd} = [\&resize_cb, $this ];

	#INvoke Superclass fill func
    $this->SUPER::Populate($args);