## PListbox - Based on MListbox Version 1.11 (26 Dec 2001)
## Modified by Ernie Miller <neo@neorants.com> (8/28/2003)
##
## 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 paren
+t 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/, 'white'
+],
            -foreground    => [qw/SELF foreground Foreground/, $Tk::NO
+RMAL_FG],
            -updatecommand => ['CALLBACK'],
            -xscancommand  => ['CALLBACK'],
            -dblclickcommand => ['CALLBACK'],
        );
    }
   
   sub BeginSelect {
      my ($w, $el) = @_;
      my $plistbox = $w->parent()->parent()->parent()->parent()->paren
+t();
      $w->SUPER::BeginSelect($el);
      $plistbox->Callback('-selectcommand', $plistbox) if $plistbox->c
+get('-selectcommand');
      $plistbox->focus();
   }
   
    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 retain
+ed.
{
    package Tk::HButton;
    use base qw(Tk::Derived Tk::Button);
    require Tk::Compound;
    Tk::Widget->Construct('HButton');
    
    sub Populate {
        my ($w, $args) = @_;
        $w->SUPER::Populate($args);
        $w->ConfigSpecs(
            -pixelwidth => ['PASSIVE'],
            -background    => [qw/SELF background Background/, $Tk::NO
+RMAL_BG],
            -foreground    => [qw/SELF foreground Foreground/, $Tk::NO
+RMAL_FG],
    );
    }

   sub setImage {
      my ($w, $image) = @_;
      my $oldimage = $w->cget('-image');
      my $c = $w->Compound;
      $c->Line;
      $c->Text(
               -text => $w->cget('-text'),
              );
      if (defined($image)) {
         if ($image eq 'up') {
            $c->Bitmap(-bitmap => 'uparrow');
         } elsif ($image eq 'down') {
            $c->Bitmap(-bitmap => 'downarrow');
         } else {
            $c->Space(-width => 15);
         }
      }
      $w->configure(-image => $c);
      $oldimage->delete if (defined($oldimage));
   }

    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/);

    my $f = $w->Component(
            Frame => "frame"
    )->pack(qw/-side left -anchor e -fill y -expand 1/);
    
    my $hdr = $f->HButton(
            -takefocus=>0,
        -padx=>0,
        -width=>1,
        -borderwidth=>2,
            -highlightthickness=>0
        )->pack(qw/-side top -anchor n -fill x/);
    $w->Advertise("heading" => $hdr);
    
    my $lb = $f->CListbox(
        -highlightthickness=>0,
        -relief=>'flat',
        -bd=>0,
        -exportselection=>0,
        -takefocus=>0
        )->pack(qw/-side top -anchor n -expand 1 -fill both/);
    $w->Advertise("listbox" => $lb);
       
    $w->Delegates (DEFAULT => $lb);
    


    $w->ConfigSpecs(
        -background     => [[$f, $hdr, $lb], 
                                qw/background Background/, $Tk::NORMAL
+_BG],
            -comparecommand => ['CALLBACK', undef, undef,
                sub{$_[0] cmp $_[1]}],
        -configurecommand => ['CALLBACK'],

        -font           => [[$hdr, $lb], qw/font Font/, undef],
            -foreground     => [[$hdr, $lb],
                                qw/foreground Foreground/, $Tk::NORMAL
+_FG],
        -separatorwidth => [{-width => $sep}, 
                                qw/separatorWidth Separator 1/],
        -separatorcolor => [{-background => $sep}, 
                                qw/sepaatorColor Separator black/],
        -resizeable     => [qw/METHOD resizeable Resizeable 1/],
        -sortable       => [qw/PASSIVE sortable Sortable 1/],
        -text           => [$hdr],
        -updatecommand  => [$lb],
        -dblclickcommand => [$lb],
        -textwidth      => [{-width => [$lb, $hdr]}],
        DEFAULT         => [$lb]
    );
    $w->ConfigAlias(
        -comparecmd => '-comparecommand',
        -width      => '-textwidth'
        );

    }

######################################################################
## MLColumn Configuration methods (call via configure/cget). 
######################################################################

    sub resizeable {
        my ($w, $value) = @_;
        return $w->{Configure}{-resizeable} unless
            defined $value;
        $w->Subwidget("separator")->configure(
            -cursor => ($value ? 'sb_h_double_arrow' : 'left_ptr')
        );
        if ($value) {
            $w->Subwidget("separator")->bind( "<B1-Motion>", 
                                              [$w=>'adjustMotion']);
            $w->Subwidget("separator")->bind("<ButtonRelease-1>", 
                                              [$w=>'Callback','-config
+urecommand']);
        } else {
            $w->Subwidget("separator")->bind( "<B1-Motion>", 
                                              '');
            $w->Subwidget("separator")->bind("<ButtonRelease-1>", 
                                              '');
        }
    }

    sub compare {
        my ($w,$a,$b) = @_;
        $w->Callback(-comparecommand => $a, $b);
    }

    sub setWidth {
        my ($w, $pixels) = @_;
        $pixels -= $w->Subwidget("separator")->width;
        return 
            unless $pixels >= 0;
    
        $w->Subwidget("listbox")->GeometryRequest(
            $pixels,$w->Subwidget("listbox")->height);
        $w->Subwidget("heading")->configure(-pixelwidth=>$pixels);
    }

######################################################################
## MLColumn Private  methods (Do not depend on these methods being pre
+sent)
######################################################################

## Adjust size of column.
    sub adjustMotion {
        my ($w) = @_;    
        $w->setWidth($w->pointerx - $w->rootx);
    }

} ## END PRELOADING OF MLColumn

######################################################################
## Package: Tk::MListbox
## Purpose: Multicolumn widget used to display tabular data
##          This widget has the ability to sort data by column,
##          hide/show columns, and the ability to change the order
##          of columns on the fly

package PListbox;
use strict;
use Carp;
use vars qw($VERSION);
$VERSION = '1.11';

use Tk;

## Overidden Scrolled method to suit the purposes of MListbox
## I want -columns to be configured LAST no matter what.
## I know full well that I'm overriding the Scrolled method
## and I don't need a warning broadcasting the fact.

no warnings;
sub Tk::Widget::Scrolled {
    my ($parent, $kind, %args) = @_;
 
    my $colAR;
    $colAR = delete $args{'-columns'} if $kind eq "PListbox";

    ## Find args that are Frame create time args
    my @args = Tk::Frame->CreateArgs($parent,\%args);
    my $name = delete $args{'Name'};
    push(@args,'Name' => $name) if (defined $name);
    my $cw = $parent->Frame(@args);
    @args = ();

    ## Now remove any args that Frame can handle
    foreach my $k ('-scrollbars',map($_->[0],$cw->configure)) {
        push(@args,$k,delete($args{$k})) if (exists $args{$k})
    }
    ## Anything else must be for target widget - pass at widget create
+ time
    my $w  = $cw->$kind(%args);

    ## Now re-set %args to be ones Frame can handle
    ## RCS NOTE: I've also slightly modified the ConfigSpecs
    %args = @args;
    $cw->ConfigSpecs(
        '-scrollbars' => [qw/METHOD   scrollbars Scrollbars se/],
        '-background' => [$w, qw/background Background/, undef],
        '-foreground' => [$w, qw/foreground Foreground/, undef],
        '-takefocus'  => ['SELF', qw/takeFocus Focus/, 0], # Otherwise
+ we focus a frame
    );
    $cw->AddScrollbars($w);
    $cw->Default("\L$kind" => $w);
    $cw->Delegates('bind' => $w, 'bindtags' => $w, 'menu' => $w);
    $cw->ConfigDefault(\%args);
    $cw->configure(%args);
    $cw->configure(-columns => $colAR) if $colAR;
    $cw->Subwidget('yscrollbar')->configure(-takefocus => 0);
    return $cw;
}
use warnings;

require Tk::Pane;
use base qw(Tk::Frame);
Tk::Widget->Construct('PListbox');

my $downarrow = pack("b15" x 11, 
                     "...............", 
                     "...............", 
                     "...............",
                     "...111111111...",
                     "....1111111....",
                     ".....11111.....",
                     "......111......",
                     ".......1.......",
                     "...............",
                     "...............",
                     "...............");
my $uparrow = pack("b15" x 11, 
                   "...............", 
                   "...............", 
                   "...............",
                   ".......1.......",
                   "......111......",
                   ".....11111.....",
                   "....1111111....",
                   "...111111111...",
                   "...............",
                   "...............",
                   "...............");

sub ClassInit {
    my ($class,$mw) = @_;
    $mw->bind($class,
              '<MouseWheel>',
              [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') },
+ Tk::Ev("D")],
             );
    $mw->bind($class,'<Configure>',['_yscrollCallback']);
    $mw->bind($class,'<Down>',['_upDown',1]);
    $mw->bind($class,'<Up>',  ['_upDown',-1]);
    $mw->bind($class,'<Shift-Up>',  ['_extendUpDown',-1]);
    $mw->bind($class,'<Shift-Down>',['_extendUpDown',1]);
    $mw->bind($class,'<Control-Home>','_cntrlHome');
    $mw->bind($class,'<Control-End>','_cntrlEnd');
    $mw->bind($class,'<Shift-Control-Home>',['_dataExtend',0]);
    $mw->bind($class,'<Shift-Control-End>',['_dataExtend',Ev('index', 
+'end')]);
    $mw->bind($class,'<Control-slash>','_selectAll');
    $mw->bind($class,'<Control-backslash>','_deselectAll');
    $mw->bind($class,'<FocusIn>','_focusin');
    $mw->DefineBitmap('downarrow' => 15, 11,
                      $downarrow);
    $mw->DefineBitmap('uparrow' => 15, 11,
                      $uparrow);
}

sub _focusin {
   my $w = shift;
   $w->selectionSet($w->curselection || 0);
   if ($w->curselection) {
      $w->activate($w->curselection);
   }
}

## Do some slightly tricky stuff: The -columns option, if called is
## guaranteed to be confiugred last of all the options submitted.
## NOTE: The args hash is cleared out if a columns option is sent
## so that all the options won't be reconfigured again immediately
## after this method finishes. ALso, if Scrolled is called, then
## the -columns option will never make it down to this level so 

sub InitObject {
    my ($w, $args) = @_;

    my $colAR = delete $args->{'-columns'};
    $w->Populate($args);
    $w->ConfigDefault($args);
    if ($colAR) {
        $w->configure(%$args);
        $w->configure(-columns => $colAR);
        %$args = ();
    }
}

sub Populate {
    my ($w, $args) = @_;

#    $w->SUPER::Populate($args);   

    $w->{'_columns'} = [];          ## Array of MLColumn objects 
    $w->{'_sortcol'} = -1;          ## Column used for sorting
    $w->{'_sort_descending'} = 0;   ## Flag for ascending/desc. sort o
+rder
    $w->{'_top'} = 0;
    $w->{'_bottom'} = 0;
    
    my $pane = $w->Component(
        Pane => "pane",
        -sticky => 'nsew'
    )->pack(-expand=>1,-fill=>'both');

    my $font;
    if ($Tk::platform eq 'MSWin32') {
        $font = "{MS Sans Serif} 8";
    } else {
        $font = "Helvetica -12 bold";
    }

    $w->ConfigSpecs(
        -background        => [qw/METHOD background Background/, 
                      $TK::NORMAL_BG ],
        -columns           => [qw/METHOD/],
    -configurecommand  => [qw/CALLBACK/],
        -font              => [qw/METHOD font Font/, $font],
        -foreground        => [qw/METHOD foreground Foreground/,
                              $Tk::NORMAL_FG ],
    -height            => [qw/METHOD height Height 10/],
    -moveable          => [qw/PASSIVE moveable Moveable 1/],
        -resizeable        => [qw/METHOD resizeable Resizeable 1/],
        -selectbackground  => [qw/METHOD selectBackground Background/,
+ 
                  $Tk::SELECT_BG],
        -selectborderwidth => [qw/METHOD selectBorderwidth Borderwidth
+ 1/],
        -selectforeground  => [qw/METHOD selectForeground Foreground/,
                  $Tk::SELECT_FG],
        -selectmode        => [qw/METHOD selectMode Mode browse/],
        -separatorcolor    => [qw/METHOD separatorColor Separator blac
+k/],
        -separatorwidth    => [qw/METHOD separatorWidth Separator 1/],
+ 
    -sortable          => [qw/METHOD sortable Sortable 1/],
        -takefocus         => [qw/PASSIVE takeFocus Focus 1/],
        -textwidth         => [qw/METHOD textWidth Width 0/],
        -width             => [qw/METHOD width Width/, 0],
          -xscrollcommand    => [$pane],
    -yscrollcommand    => ['CALLBACK'],
    -selectcommand      => ['CALLBACK'],
    );

    $w->ConfigAlias(
        -selectbg => "-selectbackground",
        -selectbd => "-selectborderwidth",
    -selectfg => "-selectforeground",
        -sepcolor => "-separatorcolor",
        -sepwidth => "-separatorwidth",
    );
}

######################################################################
## Configuration methods (call via configure). 
######################################################################

## Background is a slightly tricky option, this option would be a 
## great candidate for "DESCENDANTS", except for the separator subwidg
+et in
## each column set by separatorcolor which I'd prefer not to set in su
+ch
## a clumsy way. All other background colors are fair game, but I'd li
+ke 
## to leave open the possibility for other exceptions such as separato
+r. 
## Besides I prefer that composite subwidgets manage their own compone
+nt parts
## as much as possible.

sub background { 
    my ($w, $val) = @_;
    return $w->{Configure}{'-background'}
        unless $val;
  
    ## Ensure that the base Frame, pane and columns (if any) get set
    Tk::configure($w, "-background", $val);
    $w->Subwidget("pane")->configure("-background", $val);
    $w->_configureColumns("-background", $val);
}

## columns needs to be called last during creation time if set and I 
## went to a great deal of trouble to guarantee this. The reason
## being is that it needs to use many of the other configurations to
## use as defaults for columns, and the ability to override any of the
+m
## for individual columns. If these options (that the columns override
+)
## were called afterwards, then the reverse would happen. All the defa
+ult
## would override the individually specified options.

sub columns {
    my ($w, $vAR) = @_;
    return $w->{Configure}{'-columns'} unless
        defined $vAR;
    $w->columnDelete(0, 'end');
    map {$w->columnInsert('end', @$_)} @$vAR; 
}

sub getsortcol {
   return $_[0]->{'_sortcol'};
}

sub getsortdescending {
   return $_[0]->{'_sort_descending'};
}

sub font              { shift->_configureColumns('-font', @_) }
sub foreground        { shift->_configureColumns('-foreground', @_) }
sub height            { shift->_configureColumns('-height', @_) }
sub resizeable        { shift->_configureColumns('-resizeable', @_) }
sub selectbackground  { shift->_configureColumns('-selectbackground', 
+@_) }
sub selectborderwidth { shift->_configureColumns('-selectborderwidth',
+ @_) }
sub selectforeground  { shift->_configureColumns('-selectforeground', 
+@_) }
sub selectmode        { shift->_configureColumns('-selectmode', @_) }
sub separatorcolor    { shift->_configureColumns('-separatorcolor', @_
+ ) }
sub separatorwidth    { shift->_configureColumns('-separatorwidth', @_
+ ) }
sub sortable          { shift->_configureColumns('-sortable', @_) }
sub textwidth         { shift->_configureColumns('-textwidth', @_) }

sub width {
    my ($w, $v) = @_;

    return $w->{Configure}{'-width'} unless defined $v;
    if ($v == 0) {
        $w->afterIdle(['_setWidth', $w]);
    } else {
        $w->Subwidget('pane')->configure(-width => $v);
    }
}

######################################################################
## Private  methods (Do not depend on these methods being present)
##
## For all methods which have _firstVisible, the method is delegated 
## to the first visible (packed) Listbox
######################################################################

## This is the main callback that is bound to the subwidgets
## when using any of the public bind methods, The defined 
## defined callback ($cb) is called from within it

sub _bindCallback {
    my ($w, $cb, $sw, $ci, $yCoord) = @_;

    my $iHR = { '-subwidget' => $sw, '-column' => $ci };
    if (defined($yCoord)) {
        $iHR->{'-row'} = $w->_getEntryFromY($sw, $yCoord);
    }
    if (ref $cb eq 'ARRAY') {
    my ($code,@args) = @$cb;
    return $w->$code($iHR, @args);
    } else {
    return $w->$cb($iHR);
    }
}

## bind subwidgets is used by other public bind methods to
## apply a callback to an event dequence of a particular subwidget 
## within each of the columns. Any defined callbacks are passed
## to the _bindCallback which is actually the callback that gets
## bound. 

sub _bindSubwidgets {
    my ($w,$subwidget,$sequence,$callback) = @_;
    my $col = 0;
    
    return (keys %{$w->{'_bindings'}->{$subwidget}})
        unless (defined $sequence);

    unless (defined $callback) {
    $callback = $w->{'_bindings'}->{$subwidget}->{$sequence};
    $callback = '' unless defined $callback;
    return $callback;
    }
    
    if ($callback eq '') {
    foreach (@{$w->{'_columns'}}) {
        $_->Subwidget($subwidget)->Tk::bind($sequence,'');
    }
    delete $w->{'_bindings'}->{$subwidget}->{$sequence};
    return '';
    }
    my @args = ('_bindCallback', $callback);
    foreach (@{$w->{'_columns'}}) {
        my $sw = $_->Subwidget($subwidget);
        if ($sw->class ne "CListbox") {
        $sw->Tk::bind($sequence, [$w => @args, $sw, $col++]);
    } else {
        $sw->Tk::bind($sequence, [$w => @args, $sw, $col++, Ev('y')]);
        }
    }
    $w->{'_bindings'}->{$subwidget}->{$sequence} = $callback;
    return '';
}

## handles config options that should be propagated to all MLColumn 
## subwidgets. Using the DEFAULT setting in ConfigSpecs would be one 
## idea, but the pane subwidget is also a child, and Pane will not 
## be able to handle many of the options being passed to this method.

sub _configureColumns {
    my ($w, $option, $value) = @_;
    return $w->{Configure}{$option}
        unless $value;

    foreach (@{$w->{'_columns'}}) {
    $_->configure("$option" => $value);
    }
}

sub _cntrlEnd  { shift->_firstVisible->Cntrl_End; }

sub _cntrlHome { shift->_firstVisible->Cntrl_Home; }

sub _dataExtend {
    my ($w, $el) = @_;
    my $mode = $w->cget('-selectmode');
    if ($mode eq 'extended') {
        $w->activate($el);
        $w->see($el);
        if ($w->selectionIncludes('anchor')) {
            $w->_firstVisible->Motion($el)
        }
    } elsif ($mode eq 'multiple') {
        $w->activate($el);
        $w->see($el)
    }
}

sub _deselectAll {
    my $w = shift;
    if ($w->cget('-selectmode') ne 'browse') {
        $w->selectionClear(0, 'end');
    }
}

## implements sorting and dragging & drop of a column
sub _dragOrSort {
    my ($w, $c) = @_;
 
    unless ($w->cget('-moveable')) {
    if ($c->cget('-sortable')) {
        $w->sort (undef, $c);
    }
    return;
    }
    
    my $h=$c->Subwidget("heading");  # The heading button of the colum
+n.
    
    my $start_mouse_x = $h->pointerx;
    my $y_pos = $h->rooty;  # This is constant through the whole opera
+tion.
    my $width = $h->width;
    my $left_limit = $w->rootx - 1;
    
    # Find the rightmost, visible column
    my $right_end = 0;
    foreach (@{$w->{'_columns'}}) {
    if ($_->rootx + $_->width > $right_end) {
        $right_end = $_->rootx + $_->width;
    }
    }        
    my $right_limit = $right_end + 1;
   
    # Create a "copy" of the heading button, put it in a toplevel that
+ matches
    # the size of the button, put the toplevel on top of the button.
    my $tl=$w->Toplevel; 
    $tl->overrideredirect(1);
    $tl->geometry(sprintf("%dx%d+%d+%d",
              $h->width, $h->height, $h->rootx, $y_pos));

    my $b=$tl->HButton
    (map{defined($_->[4]) ? ($_->[0]=>$_->[4]) : ()} $h->configure)
        ->pack(-expand=>1,-fill=>'both');
    
    # Move the toplevel with the mouse (as long as Button-1 is down).
    $h->bind("<Motion>", sub {
    my $new_x = $h->rootx - ($start_mouse_x - $h->pointerx);
    unless ($new_x + $width/2 < $left_limit ||
        $new_x + $width/2 > $right_limit) 
    {
        $tl->geometry(sprintf("+%d+%d",$new_x,$y_pos));
    }
    });

    $h->bind("<ButtonRelease-1>", sub {
    my $rootx = $tl->rootx;
    my $x = $rootx + ($tl->width/2);
    $tl->destroy;    # Don't need this anymore...
    $h->bind("<Motion>",'');  # Cancel binding

    if ($h->rootx == $rootx) {    
        # Button NOT moved, sort the column....
        if ($c->cget('-sortable')) {
        $w->sort(undef, $c);
        }
        return;
    }
        
    # Button moved.....
    # Decide where to put the column. If the center of the dragged 
    # button is on the left half of another heading, insert it -before
+ 
    # the column, otherwise insert it -after the column.
    foreach (@{$w->{'_columns'}}) {
        if ($_->ismapped) {
        my $left = $_->rootx;
        my $right = $left + $_->width;
        if ($left <= $x && $x <= $right) {
            if ($x - $left < $right - $x) {
            $w->columnShow($c,-before=>$_);
            } else {
            $w->columnShow($c,'-after'=>$_);
            }
            $w->update;
            $w->Callback(-configurecommand => $w);
        }
        }
    }
    });
}

sub _extendUpDown {
    my ($w, $amount) = @_;
    if ($w->cget('-selectmode') ne 'extended') {
        return;
    }
    $w->activate($w->index('active')+$amount);
    $w->see('active');
    $w->_motion($w->index('active'))
}

## Many of the methods in this package are very similar in that they
## delagate calls to the MLColumn widgets. Because widgets can be
## be moved around (repacked) and hidden (packForget), any
## one widget may not be the "best" to be delegating calls to. The
## _columns variable holds an array of the columns but the order of 
## this array does not correspond to the order in which they might 
## by displayed, therefore this method is used to return the first
## "visible" or packed MLColumn. RCS Note: It might be reasonable to
## make this a public method as it could conceivably useful to someone
## who might want to subclass this widget or use their own bindings.
sub _firstVisible {
    my $w = shift;
    foreach my $c (@{$w->{'_columns'}}) {
    return $c if $c->ismapped;
    }
    return $w->{'_columns'}->[0];
}

sub _getEntryFromY {
    my ($cw, $sw, $yCoord) = @_;
    my $nearest = $sw->nearest($yCoord);
 
    return $nearest
        if ($nearest < ($sw->size() - 1));
   unless ($nearest == -1) {
      my ($x, $y, $w, $h) = $sw->bbox($nearest);
      my $lastY = $y + $h;
      return -1 
          if ($yCoord > $lastY);
      return $nearest;
   }
}

## Used to distribute method calls which would otherwise be called for
## for one CListbox (Within a column), Each CListbox is a modified 
## Listbox whose methods end up passing the code and arguments that ne
+ed
## to be called to this method where they are invoked for each column
## It's an interesting, although complex, interaction and it's worth 
## tracing to follow the program flow.

sub _motion    { shift->_firstVisible->Motion(@_) }
sub _selectAll { shift->_firstVisible->SelectAll; }

sub _selectionUpdate {
    my ($w, $code, $l, @args) = @_;

    if (@args) {
    foreach (@{$w->{'_columns'}}) {
        &$code($_->Subwidget("listbox"), @args);
    }
    } else {
    &$code($w->{'_columns'}->[0]->Subwidget("listbox"));
    }
}

## dynamically sets the width of the widget by calculating
## the width of each of the currently visible columns. 
## This is generally called during creation time when -width
## is set to 0.

sub _setWidth {
    my ($w) = shift;
    my $width = 0;
    foreach my $c (@{$w->{'_columns'}}) {
        my $lw = $c->Subwidget('listbox')->reqwidth;
        my $sw = $c->Subwidget('separator')->reqwidth;
        $width += ($lw + $sw);
    }
    $w->Subwidget('pane')->configure(-width => $width);
}

sub _upDown {
   my $w = shift;
   $w->_firstVisible->UpDown(@_);
   $w->Callback('-selectcommand', $w) if $w->cget('-selectcommand');
}

sub _yscrollCallback  {
    my ($w, $top, $bottom) = @_;

    unless ($w->cget(-yscrollcommand)) {
    return;
    }

    unless (defined($top)) {
    # Called internally
    my $c = $w->_firstVisible;
    if (Exists($c) && $c->ismapped){
        ($top,$bottom) = $c->yview;
    } else {
        ($top,$bottom) = (0,1);
    }
    } 
    
    if ($top != $w->{'_top'} || $bottom != $w->{'_bottom'}) {
    $w->Callback(-yscrollcommand=>$top,$bottom);
    $w->{'_top'} = $top;
    $w->{'_bottom'} = $bottom;
    }
}

######################################################################
## Exported (Public) methods (listed alphabetically)
######################################################################

## Activate a row
sub activate { shift->_firstVisible->activate(@_)}

sub bindColumns    {  shift->_bindSubwidgets('heading',@_) }
sub bindRows       {  shift->_bindSubwidgets('listbox',@_) }
sub bindSeparators {  shift->_bindSubwidgets('separator',@_) }

sub columnConfigure {
    my ($w, $index, %args) = @_;
    $w->columnGet($index)->configure(%args);
}

## Delete a column.
sub columnDelete {
    my ($w, $first, $last) = @_;

    for (my $i=$w->columnIndex($first); $i<=$w->columnIndex($last); $i
+++) {
    $w->columnGet($i)->destroy;
    }
    @{$w->{'_columns'}} = map{Exists($_) ? $_ : ()} @{$w->{'_columns'}
+};
}

sub columnGet {
    my ($w, $from, $to) = @_;
    if (defined($to)) {
    $from= $w->columnIndex($from);
    $to = $w->columnIndex($to);
    return @{$w->{'_columns'}}[$from..$to];
    } else {
    return $w->{'_columns'}->[$w->columnIndex($from)];
    }
}

sub columnHide {
    my ($w, $first, $last) = @_;
    $last = $first unless defined $last;

    for (my $i=$w->columnIndex($first); $i<=$w->columnIndex($last); $i
+++) {
    $w->columnGet($i)->packForget;
    }
}

## Converts a column index to a numeric index. $index might be a numbe
+r,
## 'end' or a reference to a MLColumn widget (see columnGet). Note tha
+t
## the index return by this method may not match up with it's current
## visual location due to columns being moved around

sub columnIndex {    
    my ($w, $index, $after_end) = @_;

    if ($index eq 'end') {
    if (defined $after_end) {
        return $#{$w->{'_columns'}} + 1;
    } else {
        return $#{$w->{'_columns'}};
    }
    } 
    
    if (ref($index) eq "Tk::MLColumn") {
    foreach (0..$#{$w->{'_columns'}}) {
        if ($index eq $w->{'_columns'}->[$_]) {
        return $_;
        }
    }
    } 

    if ($index =~ m/^\s*(\d+)\s*$/) {
    return $1;
    }    
    croak "Invalid column index: $index\n";
}

## Insert a column. $index should be a number or 'end'. 
sub columnInsert {
    my ($w, $index, %args) = @_;
   
    $index = $w->columnIndex($index,1);
    my %opts = ();
    
    ## Copy these options from the megawidget.
    foreach (qw/-background -foreground -font -height 
        -resizeable -selectbackground -selectforeground 
        -selectborderwidth -selectmode -separatorcolor
        -separatorwidth -sortable -textwidth/) 
    {
    $opts{$_} = $w->cget($_) if defined $w->cget($_);
    }
    ## All options (and more) might be overridden by %args.
    map {$opts{$_} = $args{$_}} keys %args;
    
    my $c = $w->Subwidget("pane")->MLColumn(%opts, 
        -yscrollcommand  =>  [ $w => '_yscrollCallback'],
    -configurecommand => [ $w => 'Callback', '-configurecommand', $w],
    -xscancommand =>     [ $w => 'xscan' ],
    -updatecommand =>    [ $w => '_selectionUpdate']
    );
    $c->Subwidget('heading')->setImage('none');
    
    ## RCS: Review this later - questionable implementation
    ## Fill the new column with empty values, making sure all columns 
+have
    ## the same number of rows.
    unless (scalar(@{$w->{'_columns'}}) == 0) {
    foreach (1..$w->size) {
        $c->insert('end','');
    }
    }  
    $c->Subwidget("heading")->bind("<Button-1>", [ $w => '_dragOrSort'
+, $c]);
    
    my $carr = $w->{'_columns'};
    splice(@$carr,$index,0,$c);

    ## Update the selection to also include the new column.
    map {$w->selectionSet($_, $_)} $w->curselection
        if $w->curselection;

    ## Copy all bindings that are created by calls to 
    ## bindRows, bindColumns and/or bindSeparators.
    ## RCS: check this out, on the next pass
    foreach my $subwidget (qw/listbox heading separator/) {
    foreach (keys %{$w->{'_bindings'}->{$subwidget}}) {
        $c->Subwidget($subwidget)->Tk::bind($_, 
                [
                    $w => 'bindCallback', 
                    $w->{'_bindings'}->{$subwidget}->{$_},
                    $index
                ]
            );
    }
    }
    
    if (Tk::Exists($w->{'_columns'}->[$index+1])) {
    $w->columnShow($index, -before=>$index+1);
    } else {
    $w->columnShow($index);
    }
    return $c;
}

sub columnPack {
    my ($w, @packinfo) = @_;
    $w->columnHide(0,'end');
    foreach (@packinfo) {
    my ($index, $width) = split /:/;
    $w->columnShow ($index);
    if (defined($width) && $width =~ /^\d+$/) {
        $w->columnGet($index)->setWidth($width)
    }
    }
}

sub columnPackInfo {
    my ($w) = @_;

    ## Widget needs to have an update call first, otherwise
    ## the method will not return anything if called prior to
    ## MainLoop - RCS

    $w->update;
    map {$w->columnIndex($_) . ':' . $_->width} 
       sort {$a->rootx <=> $b->rootx}
          map {$_->ismapped ? $_ : ()} @{$w->{'_columns'}};
}    

sub columnShow {
    my ($w, $index, %args) = @_;
    
    my $c = $w->columnGet($index);
    my @packopts = (-anchor=>'w',-side=>'left',-fill=>'both');
    if (defined($args{'-before'})) {
    push (@packopts, '-before'=>$w->columnGet($args{'-before'}));
    } elsif (defined($args{'-after'})) {
    push (@packopts, '-after'=>$w->columnGet($args{'-after'}));
    }
    $c->pack(@packopts);
}

sub curselection { shift->_firstVisible->curselection(@_)}

sub delete {
    my $w = shift;
    foreach (@{$w->{'_columns'}}) {
    my $saved_width = $_->width;
        $_->delete(@_);
    if ($_->ismapped) {
        $_->setWidth($saved_width);
    }
    }
    $w->_yscrollCallback;
}
    
sub get {
    my @result = ();
    my ($colnum,$rownum) = (0,0);
    
    foreach (@{shift->{'_columns'}}) {
    my @coldata = $_->get(@_);
    $rownum = 0;
    map {$result[$rownum++][$colnum] = $_} @coldata;
    $colnum++;
    }
    @result;
}

sub getRow {
    my @result = map {$_->get(@_)} @{shift->{'_columns'}};
    if (wantarray) {
    @result;
    } else {
    $result[0];
    }
}
    
sub index { shift->_firstVisible->index(@_)}

sub insert {
    my ($w, $index, @data) = @_;
    my ($rownum, $colnum);
    
     if ($index eq 'sorted') {
        $index = 0;
        my $lastindex = $w->{'_columns'}->[0]->size - 1;
        unless ($lastindex < 0) {
         until ($index > $lastindex) {
            if ($w->{'_sort_descending'}) {
               last if ($w->{'_columns'}->[$w->{'_sortcol'}]->compare(
+$data[0]->[$w->{'_sortcol'}],($w->getRow($index))[$w->{'_sortcol'}]) 
+> 0)
            } else {
               last if ($w->{'_columns'}->[$w->{'_sortcol'}]->compare(
+$data[0]->[$w->{'_sortcol'}],($w->getRow($index))[$w->{'_sortcol'}]) 
+< 0)
            }
            $index++;
         }
        }
        $index = 'end' if ($index > $lastindex);
     }


    # Insert data into one column at a time, calling $listbox->insert
    # ONCE for each column. (The first version of this widget call ins
+ert
    # once for each row in each column).
    # 
    foreach $colnum (0..$#{$w->{'_columns'}}) {    
    my $c = $w->{'_columns'}->[$colnum];
    
    # The listbox might get resized after insert/delete, which is a 
    # behaviour we don't like....
    my $saved_width = $c->width;

    my @coldata = ();

    foreach (0..$#data) {
        if (defined($data[$_][$colnum])) {
        push @coldata, $data[$_][$colnum];
        } else {
        push @coldata, '';
        }
    }
    $c->insert($index,@coldata);
    
    if ($c->ismapped) {
        # Restore saved width.
        $c->setWidth($saved_width);
    } 
    }    
    $w->_yscrollCallback;
    return ($index);
}

## These methods all delegate to the first visible column's
## Listbox. Refer to Listbox docs and description for _firstVisible

sub nearest           { shift->_firstVisible->nearest(@_)}
sub see               { shift->_firstVisible->see(@_)}
sub selectionAnchor   { shift->_firstVisible->selectionAnchor(@_)}
sub selectionClear    { shift->_firstVisible->selectionClear(@_)}
sub selectionIncludes { shift->_firstVisible->selectionIncludes(@_)}
sub size              { shift->_firstVisible->size(@_)}
sub selectionSet      { shift->_firstVisible->selectionSet(@_) }

sub sort {
    my ($w, $descending, @indexes) = @_;
    # Hack to avoid problem with older Tk versions which do not suppor
+t
    # the -recurse=>1 option.
    $w->Busy;   # This works always (but not very good...)
    Tk::catch {$w->Busy(-recurse=>1)};# This works on newer Tk version
+s,
                                      # harmless on old versions.
    foreach (0..$#{$w->{'_columns'}}) {
       $w->{'_columns'}->[$_]->Subwidget('heading')->setImage('none');
    }

    @indexes = (0..$#{$w->{'_columns'}}) unless @indexes;

    # Convert all indexes to integers.
    map {$_=$w->columnIndex($_)} @indexes;
    
    # This works on Solaris, but not on Linux???
    # Store the -comparecommand for each row in a local array. In the 
+sort,
    # the store command is called directly in stead of via the MLColum
+n
    # subwidget. This saves a lot of callbacks and function calls.
    #
    # my @cmp_subs = map {$_->cget(-comparecommand)} @{$w->{'_columns'
+}};
    
    # If sort order is not defined
    unless (defined $descending) {
    if ($#indexes == 0 &&
        $w->{'_sortcol'} == $indexes[0] &&
        $w->{'_sort_descending'} == 0)
    {
        # Already sorted on this column, reverse sort order.
        $descending = 1;
    } else {
        $descending = 0;
    }
    }

    # To retain the selection after the sort we have to save informati
+on
    # about the current selection before the sort. Adds a dummy column
    # to the two dimensional data array, this last column will be true
    # for all rows that are currently selected.
    my $dummy_column = scalar(@{$w->{'_columns'}});

    my @data = $w->get(0,'end');
    foreach ($w->curselection) {
    $data[$_]->[$dummy_column] = 1;  # Selected...
    }
    
    @data = sort {
    local $^W = 0;
    foreach (@indexes) {
        if ($descending) {
          $w->{'_columns'}->[$_]->Subwidget('heading')->setImage('down
+');
        } else {
           $w->{'_columns'}->[$_]->Subwidget('heading')->setImage('up'
+);;
        }
        my $res = do {
        if ($descending) {
            # Call via cmp_subs works fine on Solaris, but no
            # on Linux. The column->compare method is much slower...
            #
            # &{$cmp_subs[$_]} ($b->[$_],$a->[$_]);
            $w->{'_columns'}->[$_]->compare($b->[$_],$a->[$_]);
        } else {
            # &{$cmp_subs[$_]} ($a->[$_],$b->[$_]);
            $w->{'_columns'}->[$_]->compare($a->[$_],$b->[$_]);
        }
        };
        return $res if $res;
    }
    return 0;
    } @data;
        
    # Replace data with the new, sorted list.
    $w->delete(0,'end');
    $w->insert(0,@data);

    my @new_selection = ();
    foreach (0..$#data) {
    if ($data[$_]->[$dummy_column]) {
        $w->selectionSet($_,$_);
    }
    }

    $w->{'_sortcol'} = $indexes[0];
    $w->{'_sort_descending'} = $descending;
    $w->Unbusy; #(-recurse=>1);
}

# Implements horizontal scanning. 
sub xscan {
    my ($w, $type, $x) = @_;

    if ($type eq 'dragto') {
    my $dist = $w->{'_scanmark_x'} - $w->pointerx;
    
    # Looks like there is a bug in Pane: If no -xscrollcommand
    # is defined, xview() fails. This is fixed by this hack:
    #
    my $p = $w->Subwidget("pane");
    unless (defined ($p->cget(-xscrollcommand))) {
        $p->configure(-xscrollcommand => sub {});
    }
    $p->xview('scroll',$dist,'units');
    }
    $w->{'_scanmark_x'} = $w->pointerx;
}

sub xview { shift->Subwidget("pane")->xview(@_) }
sub yview { shift->_firstVisible->yview(@_)}

1;
__END__
[download]