view release on metacpan or  search on metacpan

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

If I<sequence> is specified, and I<callback> is an empty string, then the
current binding for sequence is destroyed, leaving sequence unbound. 
An empty string is returned.

An empty string is returned in all other cases.

=back

=head1 KNOWN BUGS

Setting both scrollbars to optional, ie. -scrollbars => 'osoe' causes the 
scrollbars to flicker and not work, if the initial width of the widget is 
set less than the combined width of the underlying HListbox widgets.
 
=head1 KEYWORDS

hmlistbox, smlistbox, mlistbox, listbox, hlist, widget

=head1 SEE ALSO

L<Tk::SMListbox> L<Tk::MListbox> L<Tk::HListbox>

=cut

## Tk::HMListbox
##
## Tk::HMListbox is a Tk::HList-based derivitive of Tk::SMListbox that 
## adds the ability to include either image icons or text (or both) 
## columns along with other HList-specific style and configuration options.
##
## Tk::HMListbox adds 2 new options:  "itemtype", and "reversearrow".
##
##############################################################################
## 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, HMListbox is
## is the only one intended for standalone use, the other three:
## HMCListbox, HMLColumn, HMButton are accessible as Subwidgets, but
## not intended to be used in any other way other than as 
## components of HMListbox.
##
##############################################################################
## HMCListbox 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::HMListbox::HMCListbox;
	use base qw(Tk::Derived Tk::HListbox);

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

	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::HListbox::selectionSet'),@_);
	}

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

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

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

	sub see {
		my ($w) = @_;
		$w->Callback(-updatecommand=>$w->can('Tk::HListbox::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::HListbox::yview'),@_);
		$w->Tk::HListbox::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::HListbox::scan'),
				$w, $type, $w->{'_scanmark_x'}, $y
		);
		$w->Callback(-xscancommand=>$type,$x);
	}

	sub SpaceSelect
	{
		my ($w) = @_;
#		$w->Callback(-updatecommand=>$w->can('Tk::HListbox::SpaceSelect'),@_);
		eval { shift; $w->Tk::HListbox::SpaceSelect(@_); };
	}

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

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

	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;
	}
}

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

	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;

		## HMLColumn Components
		## $sep - separator - Frame
		## $hdr - heading    - HMButton
		## $f   - frame     - Frame    
		## $lb  - listbox   - HMCListbox

		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']);