view release on metacpan or  search on metacpan

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

##
## Tk::SMListbox is a derivitive of Tk::MListbox that adds optional tiny 
## up and down arrow graphics to columns in the SMListbox that the data is 
## currently sorted on indicating ascending and/or descending order.
##
## Tk::SMListbox adds 3 new methods:  "compound", "getSortOrder" and 
## "showallsortcolumns":
##
## Version 2.x addes 2 additional methods:  "setButtonHeight" and 
## "focusColumn".
##
## $smListBox->compound gets / sets the side of the column header that the 
## ascending / descending arrow is to appear (left, right, top, bottom), 
## default is "right".
##
## $smListBox->getSortOrder returns an array that is in the same format 
## accepted by the $smListBox->sort method.  The 1st element is either 
## true for descending sort, false for assending.  Subsequent elements 
## represent the column indices of one or more columns by which the data 
## is sorted.
##
## $smListBox->showallsortcolumns gets or sets whether a sort direction 
## arrow is to be displayed on each column involved in the sorting or just 
## the 1st (primary sort).  Default is 0 (false) - show arrow only on the 
## primary sort column.
##
## $smListBox->setButtonHeight Sets (alters) the "-pady" value for the 
## header buttons.  Should be called AFTER all columns have been created.  
##
## $smListBox->focusColumn Gets or sets the index of the column whose 
## listbox is to receive the keyboard focus when the SMListbox widget 
## receives keyboard focus (See the pod / manpage for more details).
##
##############################################################################
## MListbox Version 1.11 (26 Dec 2001)
##
## Original Author: Hans J. Helgesen, Dec 1999  
## Maintainer: Rob Seegel (versions 1.10+)
##
## This version is a maintenance release of Hans' MListbox widget.
## I have tried to avoid adding too many new features and just ensure 
## that the existing ones work properly.
## 
## Please post feedback to comp.lang.perl.tk or email to RobSeegel@aol.com
##
## This module contains four classes. Of the four MListbox is
## is the only one intended for standalone use, the other three:
## SMCListbox, SMLColumn, SMHButton are accessible as Subwidgets, but
## not intended to be used in any other way other than as 
## components of MListbox
##
##############################################################################
## SMCListbox is similar to an ordinary listbox, but with the following 
## differences:
## - Calls an -updatecommand whenever something happens to it.
## - Horizontal scanning is disabled, calls -xscancommand to let parent widget
##   handle this.

{
	package Tk::SMListbox::SMCListbox;
	use base qw(Tk::Derived Tk::Listbox);

	Tk::Widget->Construct('SMCListbox');

	sub Populate {
		my ($w, $args) = @_;
		$w->SUPER::Populate($args);
		$w->ConfigSpecs(
				-updatecommand => ['CALLBACK'],
				-xscancommand  => ['CALLBACK'],
		);
	}

	sub selectionSet {   #JWT:NOTE:Callback->can() EATS 1ST ARGUMENT, SO WE MUST *NOT* SHIFT @_!!!
		my ($w) = @_;
		$w->Callback(-updatecommand=>$w->can('Tk::Listbox::selectionSet'),@_);
	}

	sub selectionClear {
		my ($w) = @_;
		$w->Callback(-updatecommand=>$w->can('Tk::Listbox::selectionClear'),@_);
	}

	sub selectionAnchor {
		my ($w) = @_;
		$w->Callback(-updatecommand=>$w->can('Tk::Listbox::selectionAnchor'),@_);
	}

	sub activate {
		my ($w) = @_;
		$w->Callback(-updatecommand=>$w->can('Tk::Listbox::activate'),@_);
	}

	sub see {
		my ($w) = @_;
		$w->Callback(-updatecommand=>$w->can('Tk::Listbox::see'),@_);
	}

	sub yview {
		my ($w) = @_;  #JWT:NOTE:Callback->can() EATS 1ST ARGUMENT, SO WE MUST *NOT* SHIFT @_!!!
		@args = @_;
		shift @args;   #JWT:NOTE:WE DO SHIFT THE MODULE OFF BEFORE CALLING yview, ETC. DIRECTLY!
		$w->Callback(-updatecommand=>$w->can('Tk::Listbox::yview'),@_);
		$w->Tk::Listbox::yview  unless (@args);   #JWT:REQUIRED BY _yscrollCallback!
	}

	sub scan {
		my ($w,$type,$x,$y) = @_;
		# Disable horizontal scanning.
		if ($type eq 'mark') {
			$w->{'_scanmark_x'} = $x;
		}
		$w->Callback(-updatecommand=>$w->can('Tk::Listbox::scan'),
				$w, $type, $w->{'_scanmark_x'}, $y
		);
		$w->Callback(-xscancommand=>$type,$x);
	}

	sub SpaceSelect
	{
		my ($w) = @_;
		eval { shift; $w->Tk::Listbox::SpaceSelect(@_); };
	}

	sub CtrlPriorNext
	{
		my ($w) = @_;
		$w->Callback(-updatecommand=>$w->can('Tk::Listbox::CtrlPriorNext'),@_);
	}
}

##############################################################################
## SMHButton is like an ordinary Button, but with an addition option:
## -pixelwidth
## The new configure method makes sure the pixelwidth is always retained.
{
	package Tk::SMListbox::SMHButton;
	use base qw(Tk::Derived Tk::Button);   
	Tk::Widget->Construct('SMHButton');

	sub Populate {
		my ($w, $args) = @_;
		$w->SUPER::Populate($args);
		$w->ConfigSpecs(
				-pixelwidth => ['PASSIVE'],
				-bitmap => [qw/SELF bitmap bitmap/, 'noarrow'],
				-compound => [qw/SELF compound compound/, 'right'],
				-background    => [qw/SELF background Background/, undef],
				-foreground    => [qw/SELF foreground Foreground/, undef]
		);
	}

	sub configure {
		my $w = shift;
		my (@ret) = $w->SUPER::configure(@_);
		unless (@ret) {
			if (defined(my $pixels = $w->cget('-pixelwidth'))) {
				$w->GeometryRequest($pixels,$w->reqheight);
			}
		}
		return @ret;
	}
}

###############################################################################
## SMLColumn implements a single column in the SMListbox. SMLColumn is a composite
## containing a heading (an SMHButton), a listbox (SMCListbox) and a frame which  
## frame which serves as a draggable separator 
{
	package Tk::SMListbox::SMLColumn;
	use base qw(Tk::Frame);
	Tk::Widget->Construct('SMLColumn');

	sub Populate {
		my ($w, $args) = @_;
		my $undln = delete($args->{'-underline'});
		$w->SUPER::Populate($args);
		my $hdrBG = $args->{'-headerbackground'} || $args->{'-background'} || undef;
		my $hdrFG = $args->{'-headerforeground'} || $args->{'-foreground'} || undef;
		my $disableFG = $args->{'-disabledforeground'} || undef;

		## SMLColumn Components
		## $sep - separator - Frame
		## $hdr - heading    - SMHButton
		## $f   - frame     - Frame    
		## $lb  - listbox   - SMCListbox

		my $sep = $w->Component(
				Frame   => 'separator',
				-height => 1,
				-takefocus => 0,
		)->pack(qw/-side right -fill y -anchor w/);

		$sep->bind( "<B1-Motion>", 
		[$w=>'adjustMotion']);
		$sep->bind("<ButtonRelease-1>", 
		[$w=>'Callback','-configurecommand']);