view release on metacpan or  search on metacpan

MListbox.pm  view on Meta::CPAN

## 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:
## CListbox, MLColumn, HButton are accessible as Subwidgets, but
## not intended to be used in any other way other than as 
## components of MListbox
##
##############################################################################
## CListbox 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::CListbox;
    use base qw(Tk::Derived Tk::Listbox);

    Tk::Widget->Construct('CListbox');
    
    sub Populate {
        my ($w, $args) = @_;
        $w->SUPER::Populate($args);
        $w->ConfigSpecs(
            -background    => [qw/SELF background Background/, $Tk::NORMAL_BG],
            -foreground    => [qw/SELF foreground Foreground/, $Tk::NORMAL_FG],
            -updatecommand => ['CALLBACK'],
            -xscancommand  => ['CALLBACK']
        );
    }
   
    sub selectionSet {
        my ($w) = @_;
        $w->Callback(-updatecommand=>$w->can('SUPER::selectionSet'),@_);
    }
    sub selectionClear {
        my ($w)=@_;
        $w->Callback(-updatecommand=>$w->can('SUPER::selectionClear'),@_);
    }
    sub selectionAnchor {
        my ($w)=@_;
        $w->Callback(-updatecommand=>$w->can('SUPER::selectionAnchor'),@_);
    }
    sub activate {
        my ($w)=@_;
        $w->Callback(-updatecommand=>$w->can('SUPER::activate'),@_);
    }
    sub see {
        my ($w)=@_;
        $w->Callback(-updatecommand=>$w->can('SUPER::see'),@_);
    }
    sub yview {
        my ($w)=@_;
        $w->Callback(-updatecommand=>$w->can('SUPER::yview'),@_);     
    }
    sub scan {
        my ($w,$type,$x,$y) = @_;
        # Disable horizontal scanning.
        if ($type eq 'mark') {
	    $w->{'_scanmark_x'} = $x;
        }
        $w->Callback(-updatecommand=>$w->can('SUPER::scan'),
	    $w, $type, $w->{'_scanmark_x'}, $y
        );
        $w->Callback(-xscancommand=>$type,$x);
    }
}

##############################################################################
## HButton is like an ordinary Button, but with an addition option:
## -pixelwidth
## The new configure method makes sure the pixelwidth is always retained.
{
    package Tk::HButton;
    use base qw(Tk::Derived Tk::Button);   
    Tk::Widget->Construct('HButton');
    
    sub Populate {
        my ($w, $args) = @_;
        $w->SUPER::Populate($args);
        $w->ConfigSpecs(
            -pixelwidth => ['PASSIVE'],
            -background    => [qw/SELF background Background/, $Tk::NORMAL_BG],
            -foreground    => [qw/SELF foreground Foreground/, $Tk::NORMAL_FG]
	);
    }

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

###############################################################################
## MLColumn implements a single column in the MListbox. MLColumn is a composite
## containing a heading (an HButton), a listbox (CListbox) and a frame which  
## frame which serves as a draggable separator 
{
    package Tk::MLColumn;
    use base qw(Tk::Frame);
    Tk::Widget->Construct('MLColumn');
    
    sub Populate {
	my ($w, $args) = @_;
	$w->SUPER::Populate($args);
       
        ## MLColumn Components
        ## $sep - separator - Frame
        ## $hdr - heading    - HButton
        ## $f   - frame     - Frame	
        ## $lb  - listbox   - CListbox

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

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

	my $f = $w->Component(
            Frame => "frame"
	)->pack(qw/-side left -anchor e -fill y -expand 1/);
	
	my $hdr = $f->HButton(
            -takefocus=>0,
	    -padx=>0,