File Coverage

blib/lib/Tk/Columns.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

#======================================================================#
#                User invokes this to add a column
#======================================================================#
package Tk::ColumnButton;

use Tk::Frame;
use Tk;

use base qw (Tk::Frame);
use vars qw ($VERSION);
use strict;
use Carp;

$VERSION = '0.02';

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

sub Populate
   {
    my $this = shift;

    my $l_Parent = $this->parent();

    $this->SUPER::Populate (@_);

    $this->{'m_TrimElements'} = [];

    my $l_Image = $this->Component
       (
        'Label' => 'Image',
        '-relief' => 'flat',
        '-anchor' => 'w',
        '-width' => 0,
        '-padx' => 0,
       );

    my $l_Label = $this->Component
       (
        'Label' => 'Label',
        '-relief' => 'flat',
        '-anchor' => 'w',
        '-padx' => 0,
       );

    my $l_Default =
       {
        '-listfont' => $l_Parent->cget ('-listfont') || $l_Label->cget ('-font'),
        '-listbackground' => $l_Parent->cget ('-listbackground') || 'white',
        '-listforeground' => $l_Parent->cget ('-listforeground') || 'black',
        '-listselectmode' => $l_Parent->cget ('-selectmode') || 'browse',
        '-selectcommand' => $l_Parent->cget ('-selectcommand') || undef,
        '-buttoncommand' => $l_Parent->cget ('-buttoncommand') || undef,
        '-foreground' => $l_Parent->cget ('-buttonforeground') || undef,
        '-background' => $l_Parent->cget ('-buttonbackground') || undef,
        '-sortcommand' => $l_Parent->cget ('-sortcommand') || undef,
        '-borderwidth' => $l_Parent->cget ('-borderwidth') || 2,
        '-trimcount' => $l_Parent->cget ('-trimcount') || 2,
        '-font' => $l_Parent->cget ('-buttonfont') || undef,
        '-image' => $l_Parent->cget ('-image') || undef,
        '-sort' => $l_Parent->cget ('-sort') || 'true',
       };

    $this->ConfigSpecs
       (
        '-background' => [['METHOD', 'CHILDREN', 'SELF'], 'background', 'Background',  $l_Default->{'-background'}],
        '-listselectmode' => ['METHOD', 'listselectmode', 'ListSelectMode', $l_Default->{'-listselectmode'}],
        '-listbackground' => ['METHOD', 'listbackground', 'ListBackground', $l_Default->{'-listbackground'}],
        '-listforeground' => ['METHOD', 'listforeground', 'ListForeground', $l_Default->{'-listforeground'}],
        '-selectcommand' => ['PASSIVE', 'selectcommand', 'SelectCommand', $l_Default->{'-selectcommand'}],
        '-buttoncommand' => ['PASSIVE', 'buttoncommand', 'ButtonCommand', $l_Default->{'-buttoncommand'}],
        '-sortcommand' => ['PASSIVE', 'sortcommand', 'Sortcommand', $l_Default->{'-sortcommand'}],
        '-borderwidth' => ['SELF', 'borderwidth', 'Borderwidth', $l_Default->{'-borderwidth'}],
        '-foreground' => ['METHOD', 'foreground', 'Foreground', $l_Default->{'-foreground'}],
        '-trimcount' => ['METHOD', 'trimcount', 'TrimCount', $l_Default->{'-trimcount'}],
        '-listfont' => ['METHOD', 'listfont', 'ListFont', $l_Default->{'-listfont'}],
        '-image' => [$l_Image, 'image', 'Image', $l_Default->{'-image'}],
        '-sort' => ['PASSIVE', 'sort', 'Sort', $l_Default->{'-sort'}],
        '-font' => [$l_Label, 'font', 'Font',  $l_Default->{'-font'}],
       );

    $this->ConfigSpecs
       (
        '-text' => [$l_Label, 'text', 'Text', '(No Title)'],
        '-relief' => ['SELF', 'relief', 'Relief', 'raised'],
        '-slave' => ['METHOD', 'slave', 'Slave', undef],
        '-zoom' => ['METHOD', 'zoom', 'Zoom', undef],
        '-width' => [$l_Label],
        'DEFAULT' => [$l_Label],
       );

    $this->ConfigSpecs
       (
        '-buttonbackground' => '-background',
        '-buttonforeground' => '-foreground',
        '-slavecolor' => '-listbackground',
        '-sortfunction' => '-sortcommand',
        '-buttoncolor' => '-background',
        '-sortmethod' => '-sortcommand',
        '-command' => '-selectcommand',
        '-color' => '-background',
        '-buttonFont' => '-font',
        '-bg' => '-background',
        '-fg' => '-foreground',
       );

    $l_Image->pack
       (
        '-expand' => 'true',
        '-side' => 'left',
        '-fill' => 'both',
        '-anchor' => 'nw',
        '-ipadx' => 0,
        '-padx' => 0,
       );

    $l_Label->pack
       (
        '-expand' => 'true',
        '-side' => 'left',
        '-fill' => 'both',
        '-anchor' => 'nw',
        '-ipadx' => 0,
        '-padx' => 0,
       );

    $this->OnDestroy
       (
        sub
           {
            my $l_Slave = $this->{'Configure'}{'-slave'};
            return unless defined ($l_Slave) && Exists ($l_Slave);
            $l_Slave->destroy();
           }
       );

    $l_Label->bind ('' => [\&ButtonPress, $this]);
    $l_Label->bind ('' => [\&ButtonRelease, $this]);
    $l_Image->bind ('' => [\&ButtonRelease, $this]);
    $l_Image->bind ('' => [\&ButtonPress, $this]);
    $this->DoWhenIdle (['UpdateSizeInfo', $this]);
    $this->configure ('-highlightthickness' => 0);
    return $this;
   }

#-----------------------------Event-Handlers----------------------------------#

sub UpdateSizeInfo
   {
    my ($this) = @_;
    my $l_Label = $this->Subwidget ('Label');
    my $l_Image = $this->Subwidget ('Image');
    $l_Label->{'m_OriginalWidth'} = $l_Label->reqwidth() if ($l_Label->reqwidth() > 1);
    $l_Image->{'m_OriginalWidth'} = $l_Image->reqwidth() if ($l_Image->reqwidth() > 1);
   }

sub SlaveInvoke
   {
    my ($this, $p_Slave) = @_;
    my $l_Command = $this->cget ('-selectcommand');
    return unless (defined ($l_Command) && defined ($p_Slave));
    &{$l_Command} (($p_Slave->curselection())[0]);
   }

sub ResizeStart
   {
    $_[1]->{'Configure'}{'-zoom'} = $_[1]->{'m_Zoomed'} = undef;
    $_[1]->{'m_X'} = $_[1]->pointerx() - $_[1]->rootx();
   }

sub ResizeEnd
   {
    my ($p_EventWidget, $this) = @_;

    return unless defined ($this->{m_X});

    my $l_Label = $this->Subwidget ('Label');
    my $l_Width = $l_Label->width() + $this->pointerx() - $this->rootx() - $this->{'m_X'};

    $l_Label->GeometryRequest ($l_Width > 0 ? $l_Width : 0, $l_Label->reqheight());
    $this->DoWhenIdle ([\&SlaveUpdate, $this]);
    $this->{'Configure'}{'-zoom'} = undef;
    $this->UpdateSizeInfo();
    $this->{'m_X'} = undef;
   }

sub Zoom
   {
    $_[1]->DoWhenIdle (['configure', $_[1], '-zoom' => (defined ($_[2]) ? $_[2] : ! $_[1]->cget ('-zoom'))]);
   }

sub SlaveUpdate
   {
    my ($this, $p_Slave) = (@_, $_[0]->cget ('-slave'));

    my $l_Label = $this->Subwidget ('Label');
    my $l_Image = $this->Subwidget ('Image');

    if ($this->{'Configure'}{'-zoom'} && $l_Label->reqwidth() > 1)
       {
        $l_Label->GeometryRequest (0, $l_Label->reqheight());
        $this->update();
       }

    #================================
    # Correct Label and Image sizes
    #================================

    if ($l_Label->reqwidth() <= 1 && $l_Image->reqwidth() > 1)
       {
        $l_Image->GeometryRequest (0, $l_Image->reqheight());
        $this->update();
       }
    elsif ($l_Label->reqwidth() > 1 && $l_Image->reqwidth() <= 1)
       {
        $l_Image->GeometryRequest ($l_Image->{'m_OriginalWidth'}, $l_Image->reqheight());
        $this->update();
       }

    if ($l_Label->reqwidth() <= 1 && ! $this->{'m_Minimized'})
       {
        foreach my $l_Child ($this->children())
           {
            next unless ($l_Child->name() =~ /^[Tt]rimElement_/);

            unless ($l_Child->name() =~ /^[Tt]rimElement_0$/)
               {
                $l_Child->packForget();
               }
           }

        $this->{'m_Minimized'} = 1;
        $this->update();
       }
    elsif ($this->{'m_Minimized'} && $l_Label->reqwidth() > 1)
       {
        foreach my $l_Child ($this->children())
           {
            next unless ($l_Child->name() =~ /^[Tt]rimElement_/);

            unless ($l_Child->name() =~ /^[Tt]rimElement_0$/)
               {
                $l_Child->pack
                   (
                    '-expand' => 'false',
                    '-side' => 'right',
                    '-anchor' => 'ne',
                    '-fill' => 'y',
                    '-ipadx' => 0,
                    '-padx' => 0,
                    '-pady' => 1,
                   );
               }
           }

        $this->{'m_Minimized'} = 0;
        $this->update();
       }

    #=====================================================
    # Slave the listbox to the current width of the button
    #=====================================================
    if (defined ($p_Slave))
       {
        $p_Slave->GeometryRequest ($this->reqwidth(), $p_Slave->reqheight());
        $p_Slave->update();
       }

    $this->update();
   }

sub ButtonPress
   {
    if ($_[1]->{'Configure'}{'-sort'} || ref ($_[1]->{'Configure'}{'-buttoncommand'}) eq 'CODE')
       {
        $_[0]->DoWhenIdle (['configure', $_[1], '-relief', 'sunken']);
        $_[1]->{'m_Sunken'} = 1;
       }
   }

sub ButtonRelease
   {
    if ($_[1]->{'Configure'}{'-sort'})
       {
        $_[0]->DoWhenIdle (['SortColumn', $_[1]]);
       }
    elsif (ref ($_[1]->{'Configure'}{'-buttoncommand'}) eq 'CODE')
       {
        &{$_[1]->{'Configure'}{'-buttoncommand'}} ($_[1], $_[1]->cget ('-slave'));
       }

    if ($_[1]->{'m_Sunken'})
       {
        $_[0]->DoWhenIdle (['configure', $_[1], '-relief', 'raised']);
        $_[1]->{'m_Sunken'} = undef;
       }
   }

sub SortColumn
   {
    my $this = shift;

    my $l_Listbox = $this->{'Configure'}{'-slave'};

    return unless (defined ($l_Listbox) && ref ($l_Listbox) eq 'Tk::TiedListbox');

    my $l_SortCommand = $this->{'Configure'}{'-sortcommand'};
    my @l_SortedKeys = $l_Listbox->get (0, 'end');
    my @l_NewOrder;
    my %l_Keys;

    for (my $l_Index = 0; $l_Index <= $#l_SortedKeys; ++$l_Index)
       {
        push (@{$l_Keys {$l_SortedKeys [$l_Index]}}, $l_Index);
       }

    if (lc ($l_SortCommand) eq 'numeric')
       {
        $l_SortCommand = '$a <=> $b';
       }
    elsif (! defined ($l_SortCommand))
       {
        $l_SortCommand = 'uc ($a) cmp uc ($b)';
       }

    @l_SortedKeys = sort {eval $l_SortCommand} (keys %l_Keys);

    unless ($l_Listbox->{'m_Reverse'} = ! $l_Listbox->{'m_Reverse'})
       {
        @l_SortedKeys = reverse (@l_SortedKeys);
       }

    foreach my $l_Key (@l_SortedKeys)
       {
        push (@l_NewOrder, @{$l_Keys {$l_Key}});
       }

    foreach my $l_Button ($this->parent()->buttons())
       {
        my $l_Listbox = $l_Button->cget ('-slave');

        next unless defined ($l_Listbox);

        my @l_Contents = $l_Listbox->get (0, 'end');
        my @l_NewContents;

        foreach my $l_NewIndex (@l_NewOrder)
           {
            push (@l_NewContents, $l_Contents [$l_NewIndex]);
           }

        $l_Listbox->delete (0, 'end');
        $l_Listbox->insert ('end', @l_NewContents);
        $l_Button->DoWhenIdle ([\&SlaveUpdate, $l_Button, $l_Listbox]);
       }
   }

#------------------------------- Private methods -----------------------------#

sub __slaveconfigure
   {
    my ($this, $p_Option, $p_Value) = (shift, @_);

    my $l_Slave = $this->{'Configure'}{'-slave'};

    if (defined ($p_Value) && defined ($l_Slave))
       {
        my $l_Method = ($l_Slave->isa ('Tk::Listbox') ? 'Tk::Listbox::configure' : 'configure');
        $this->{'Configure'}{$p_Option} = $p_Value;
        $p_Option =~ s/^\-list/-/;
        $this->DoWhenIdle ([$l_Method, $l_Slave, $p_Option, $p_Value]);
        $this->DoWhenIdle ([\&SlaveUpdate, $this]);
       }

    return $this->{'Configure'}{$p_Option};
   }

#-----------------------------'METHOD'-type-settings--------------------------#

sub slave
   {
    my ($this, $p_Slave) = @_;

    if (defined ($p_Slave) && Exists ($p_Slave))
       {
        ($this->{'Configure'}{'-slave'} = $p_Slave)->bind ('' => sub {$this->SlaveInvoke ($p_Slave);});

        $this->configure
           (
            '-listfont' => $this->cget ('-listfont'),
            '-listforeground' => $this->cget ('-listforeground'),
            '-listbackground' => $this->cget ('-listbackground'),
            '-listselectmode' => $this->cget ('-listselectmode'),
           );
       }

    return $this->{'Configure'}{'-slave'};
   }

sub trimcount
   {
    my ($this, $p_TrimCount) = (shift, @_);

    if (defined ($p_TrimCount) && $p_TrimCount >= 0)
       {
        my @l_TrimElements = @{$this->{m_TrimElements}};

        $p_TrimCount = 12 if ($p_TrimCount > 12);

        while ($p_TrimCount > $#l_TrimElements + 1)
           {
            my $l_Widget = $this->Component
               (
                'Frame' => 'TrimElement_'.($#l_TrimElements + 1),
                '-cursor' => 'sb_h_double_arrow',
                '-background' => 'white',
                '-relief' => 'raised',
                '-borderwidth' => 1,
                '-width' => 2,
               );

            $l_Widget->pack
               (
                '-expand' => 'false',
                '-side' => 'right',
                '-anchor' => 'ne',
                '-fill' => 'y',
                '-ipadx' => 0,
                '-padx' => 0,
                '-pady' => 1,
               );

            $l_Widget->bind ('' => [\&ResizeEnd, $this]);
            $l_Widget->bind ('' => [\&ResizeStart, $this]);
            $l_Widget->bind ('' => [\&Zoom, $this]);
            push @l_TrimElements, $l_Widget;
           }

        while ($p_TrimCount <= $#l_TrimElements)
           {
            (pop @l_TrimElements)->destroy();
           }

        $this->{m_TrimElements} = [@l_TrimElements];
       }

    return $#{$this->{m_TrimElements}} + 1;
   }

sub background
   {
    my ($this, $p_Color) = (shift, @_);

    if (defined ($p_Color))
       {
        my $l_OptionColor = $this->option ('get', 'background', 'Background') || $p_Color;
        my $l_ConfigColor = ${$this->ConfigSpecs()->{'-background'}}[3] || $p_Color;
        my $l_ParentColor = $this->parent()->cget ('-buttonbackground');

        my @l_Compare =
           (
            sprintf ("#%02x%02x%02x", $this->rgb ($p_Color)),
            sprintf ("#%02x%02x%02x", $this->rgb ($l_ConfigColor)),
            sprintf ("#%02x%02x%02x", $this->rgb ($l_OptionColor)),
           );

        $this->{'Configure'}{'-background'} = $p_Color =
           (
            defined ($l_ParentColor) &&
            $l_Compare [0] eq $l_Compare [1] &&
            $l_Compare [0] eq $l_Compare [2] &&
            ! defined ($this->{'m_Initialized'}) ?
            $l_ParentColor :
            $p_Color
           );

        foreach my $l_Child ($this->children())
           {
            $l_Child->configure ('-background' => $p_Color);
           }

        $this->DoWhenIdle (['configure', $this, '-background' => $p_Color]) unless ($this->{'m_Initialized'} >= 2);
        $this->DoWhenIdle ([\&SlaveUpdate, $this]);
        ++$this->{'m_Initialized'};
       }

    return $this->{'Configure'}{'-background'};
   }

sub foreground
   {
    my ($this, $p_Color) = (shift, @_);

    my $l_Label = $this->Subwidget ('Label');

    if (defined ($p_Color) && defined ($l_Label))
       {
        my $l_OptionColor = $this->option ('get', 'foreground', 'Foreground') || $p_Color;
        my $l_ConfigColor = ${$this->ConfigSpecs()->{'-foreground'}}[3] || $p_Color;
        my $l_ParentColor = $this->parent()->cget ('-buttonforeground');

        my @l_Compare =
           (
            sprintf ("#%02x%02x%02x", $this->rgb ($p_Color)),
            sprintf ("#%02x%02x%02x", $this->rgb ($l_ConfigColor)),
            sprintf ("#%02x%02x%02x", $this->rgb ($l_OptionColor)),
           );

        $this->{'Configure'}{'-foreground'} = $p_Color =
           (
            defined ($l_ParentColor) &&
            $l_Compare [0] eq $l_Compare [1] &&
            $l_Compare [0] eq $l_Compare [2] &&
            ! defined ($l_Label->{'m_Initialized'}) ?
            $l_ParentColor :
            $p_Color
           );

        $l_Label->configure ('-foreground' => $p_Color);
        $this->DoWhenIdle ([\&SlaveUpdate, $this]);
        $l_Label->{'m_Initialized'} = 1;
       }

    return $this->{'Configure'}{'-foreground'};
   }

sub listbackground
   {
    return shift->__slaveconfigure ('-listbackground', @_);
   }

sub listforeground
   {
    return shift->__slaveconfigure ('-listforeground', @_);
   }

sub listfont
   {
    return shift->__slaveconfigure ('-listfont', @_);
   }

sub listselectmode
   {
    return shift->__slaveconfigure ('-listselectmode', @_);
   }

sub zoom
   {
    my ($this, $p_State) = @_;

    my $l_Label = $this->Subwidget ('Label');

    if (defined ($p_State) && defined ($l_Label))
       {
        $this->{'Configure'}{'-zoom'} = $p_State;
        $l_Label->GeometryRequest ($p_State ? 0 : $l_Label->{'m_OriginalWidth'}, $l_Label->reqheight());
        $this->DoWhenIdle ([\&SlaveUpdate, $this]);
       }

    return $this->{'Configure'}{'-zoom'};
   }

1;

#======================================================================#
#             This is a private class used only by Columns
#======================================================================#
package Tk::__ButtonContainer;

use strict;

use Carp;

use Tk::Frame;

use base qw (Tk::Frame);

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

sub Populate
   {
    my $this = shift;

    $this->SUPER::Populate (@_);

    $this->{'m_ButtonList'} = [];

    $this->ConfigSpecs
       (
        '-selectcommand' => ['METHOD', 'selectcommand', 'SelectCommand', undef],
        '-buttoncommand' => ['METHOD', 'buttoncommand', 'ButtonCommand', undef],
        '-sortcommand' => ['METHOD', 'sortcommand', 'SortCommand', undef],
        '-borderwidth' => ['METHOD', 'borderwidth', 'BorderWidth', undef],
        '-trimcount' => ['METHOD', 'trimcount', 'TrimCount', undef],
        '-image' => ['METHOD', 'image', 'Image', undef],
        '-sort' => ['METHOD', 'sort', 'Sort', undef],
        '-zoom' => ['METHOD', 'zoom', 'Zoom', undef],
        '-background' => ['METHOD'],
        '-foreground' => ['METHOD'],
        '-master' => ['PASSIVE'],
	'-font' => ['METHOD'],
       );

    $this->ConfigSpecs
       (
        '-buttonbackground' => '-background',
        '-buttonforeground' => '-foreground',
        '-buttoncolor' => '-background',
        '-command' => '-selectcommand',
        '-color' => '-background',
        '-buttonfont' => '-font',
       );

    $this->gridRowconfigure (0, '-weight' => 0);

    return $this;
   }

#-----------------------------Event-Handlers----------------------------------#

sub NoticeChild
   {
    my ($this, $p_Child) = (shift, @_);

    return unless ($p_Child->class() eq 'ColumnButton');

    push (@{$this->{'m_ButtonList'}}, $p_Child);

    my $l_ColumnIndex = $#{$this->{'m_ButtonList'}};

    $p_Child->grid
       (
        '-column' => $l_ColumnIndex,
        '-sticky' => 'nsew',
        '-row' => 0,
        '-ipadx' => 0,
        '-padx' => 0,
       );

    for (my $l_Index = 0; $l_Index <= $l_ColumnIndex; ++$l_Index)
       {
        $this->gridColumnconfigure ($l_Index, '-weight' => 0);
       }

    $this->gridColumnconfigure ($l_ColumnIndex, '-weight' => 1);

    if (defined ($this->{'Configure'}{'-master'}))
       {
        $this->{'Configure'}{'-master'}->NoticeChild (@_);
       }
   }

sub SlaveUpdate
   {
    foreach my $l_Button ($_[0]->buttons())
       {
        $l_Button->SlaveUpdate() if (defined ($l_Button));
       }
   }

sub AdjustButtonList
   {
    my @l_Array;

    foreach my $l_Button ($_[0]->buttons())
       {
        push (@l_Array, $l_Button) if (Exists ($l_Button));
       }

    return @{$_[0]->{'m_ButtonList'} = \@l_Array};
   }

#------------------------------- Private methods -----------------------------#

sub __configall
   {
    if (defined ($_[2]))
       {
        $_[0]->{'Configure'}{$_[1]} = $_[2];

        foreach my $l_Button ($_[0]->buttons())
           {
            $l_Button->configure ($_[1] => $_[2]);
            # $_[0]->DoWhenIdle (['configure', $l_Button, $_[1] => $_[2]]);
           }
       }

    return ($_[0]->{'Configure'}{$_[1]});
   }

#-----------------------------'METHOD'-type-settings--------------------------#

sub buttoncommand {return shift->__configall ('-buttoncommand', @_);}
sub selectcommand {return shift->__configall ('-selectcommand', @_);}
sub sortcommand   {return shift->__configall ('-sortcommand', @_);}
sub borderwidth   {return shift->__configall ('-borderwidth', @_);}
sub background    {return shift->__configall ('-background', @_);}
sub foreground    {return shift->__configall ('-foreground', @_);}
sub trimcount     {return shift->__configall ('-trimcount', @_);}
sub font          {return shift->__configall ('-font', @_);}
sub sort          {return shift->__configall ('-sort', @_);}
sub zoom          {return shift->__configall ('-zoom', @_);}
sub image         {return shift->__configall ('-image', @_);}

#------------------------------- Public methods -----------------------------#

sub buttons
   {
    return @{$_[0]->{'m_ButtonList'}};
   }

sub labels
   {
    return map {$_->cget ('-text')} ($_[0]->buttons());
   }

sub buttonhash
   {
    return {map {$_->cget ('-text'), $_} ($_[0]->buttons())};
   }

*hash = \&Tk::__ButtonContainer::listhash;

sub listhash
   {
    return {map {$_->cget ('-text'), $_->cget ('-slave')} ($_[0]->buttons())};
   }

sub buttoncontainer
   {
    return $_[0];
   }

*buttonwidth = \&Tk::__ButtonContainer::columnwidth;
*width = \&Tk::__ButtonContainer::columnwidth;

sub columnwidth
   {
    my ($this, $p_Column, $p_Width) = @_;

    my $l_Button = $this->indexedbutton ($p_Column);

    return unless defined ($l_Button);

    return $l_Button->cget ('-width') unless ($p_Width >= 0 && $p_Width <= 1024);

    $l_Button->configure ('-width' => $p_Width);

    return $p_Width;
   }

1;

#======================================================================#
#   This is a private class used only by the Columns
#======================================================================#
package Tk::__ListContainer;

use Tk::TiedListbox;
use Tk::Frame;
use Tk;

use base qw (Tk::Frame);
use strict;
use Carp;

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

sub Populate
   {
    my $this = shift;

    $this->SUPER::Populate (@_);

    $this->{'m_Lists'} = [];

    $this->ConfigSpecs
       (
        '-background' => ['METHOD', 'background', 'Background', 'white'],
 	'-selectmode' => ['METHOD', 'selectmode', 'SelectMode', 'single'],
        '-foreground' => ['METHOD', 'foreground', 'Foreground', 'black'],
        '-master' => ['PASSIVE'],
	'-font' => ['METHOD'],
       );

    $this->ConfigSpecs
       (
        '-listforeground' => '-foreground',
        '-listbackground' => '-background',
        '-listselectmode' => '-selectmode',
        '-listcolor' => '-background',
        '-color' => '-background',
        '-listfont' => '-font',
       );

    return $this;
   }

#-----------------------------Event-Handlers----------------------------------#

sub NoticeChild
   {
    my ($this, $p_Child) = (shift, @_);

    my $l_Length = ($#{$this->{'m_Lists'}} > -1 ? ${$this->{'m_Lists'}}[0] : $p_Child)->size();
    my @l_ListArray;

    foreach my $l_Slave ($this->lists())
       {
        $l_Slave->pack ('-expand' => 'false');
       }

    for (my $l_Index = 0; $l_Index < $l_Length; ++$l_Index)
       {
        push (@l_ListArray, undef);
       }

    $p_Child->DoWhenIdle (['insert', $p_Child, 'end', @l_ListArray]) if ($#l_ListArray > -1);
    push (@{$this->{'m_Lists'}}, $p_Child);
    @l_ListArray = ();

    foreach my $l_Slave ($this->lists())
       {
        push (@l_ListArray, $l_Slave) if ($l_Slave->class() eq 'Listbox');
       }

    $p_Child->pack ('-side' => 'left', '-anchor' => 'nw', '-expand' => 'true', '-fill' => 'both', '-padx' => 0);
    $l_ListArray[0]->tie ('all', [@l_ListArray [1..$#l_ListArray]]);
    $this->eventGenerate ('');
   }

#------------------------------- Private methods -----------------------------#

sub __configall
   {
    my ($this, $p_Option, $p_Value) = @_;

    if (defined ($p_Value))
       {
        $this->{'Configure'}{$p_Option} = $p_Value;

        foreach my $l_List ($this->lists())
           {
            $this->DoWhenIdle
               (
                [
                 $l_List->isa ('Tk::Listbox') ? 'Tk::Listbox::configure' : 'configure',
                 $l_List,
                 $p_Option => $p_Value
                ]
               );
           }

        $this->DoWhenIdle (sub {$this->SlaveUpdate();});
       }

    return ($this->{'Configure'}{$p_Option});
   }

#-----------------------------'METHOD'-type-settings--------------------------#

sub background {return shift->__configall ('-background', @_);}
sub foreground {return shift->__configall ('-foreground', @_);}
sub selectmode {return shift->__configall ('-selectmode', @_);}
sub font       {return shift->__configall ('-font', @_);}

#------------------------------- Public methods -----------------------------#

sub lists
   {
    return @{$_[0]->{'m_Lists'}};
   }

sub size
   {
    return ($#{$_[0]->{'m_Lists'}} > -1 ? ${$_[0]->{'m_Lists'}}[0]->size() : 0);
   }

sub rows
   {
    return $_[0]->size();
   }

sub listcontainer
   {
    return $_[0];
   }

sub selection
   {
    ${$_[0]->{'m_Lists'}}[0]->selection (@_) if ($#{$_[0]->{'m_Lists'}} > -1);
   }

sub curselection
   {
    return ($#{$_[0]->{'m_Lists'}} > -1 ? ${$_[0]->{'m_Lists'}}[0]->curselection() : ());
   }

sub activate
   {
    ${$_[0]->{'m_Lists'}}[0]->activate (@_) if ($#{$_[0]->{'m_Lists'}} > -1);
   }

sub nearest
   {
    return ($#{$_[0]->{'m_Lists'}} > -1 ? ${$_[0]->{'m_Lists'}}[0]->nearest (@_) : undef);
   }

sub see
   {
    ${$_[0]->{'m_Lists'}}[0]->see (@_) if ($#{$_[0]->{'m_Lists'}} > -1);
   }

1;

#======================================================================#
#
#======================================================================#
package Tk::Columns;

use Tk::Frame;
use Tk::Pane;
use Tk;

use base qw (Tk::Frame);
use strict;
use Carp;

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

sub ClassInit
   {
    $_[1]->bind ($_[0], '', ['CheckScrollbars']);
    $_[1]->bind ($_[0], '', ['CheckScrollbars']);
   }

sub Populate
   {
    my $this = shift;

    $this->SUPER::Populate (@_);

    my $l_ButtonPane = $this->Component
       (
        'Pane' => 'ButtonPane',
        '-sticky' => 'nsew',
        '-borderwidth' => 0,
       );

    my $l_SlavePane = $this->Component
       (
        'Pane' => 'SlavePane',
        '-sticky' => 'nsew',
        '-borderwidth' => 0,
       );

    my $l_HScrollbar = $this->Component
       (
        'Scrollbar' => 'HScroll',
        '-elementborderwidth' => 1,
        '-orient' => 'horizontal',
       );

    my $l_VScrollbar = $this->Component
       (
        'Scrollbar' => 'VScroll',
        '-elementborderwidth' => 1,
        '-orient' => 'vertical',
       );

    my $l_ButtonContainer = $l_ButtonPane->Component
       (
        '__ButtonContainer' => 'ButtonContainer',
        '-master' => $this,
       );

    my $l_ListContainer = $l_SlavePane->Component
       (
        '__ListContainer' => 'ListContainer',
        '-background' => 'white',
        '-borderwidth' => 0,
        '-master' => $this,
       );

    my $l_UR = $this->Frame
       (
        '-relief' => 'raised',
        '-borderwidth' => 0,
        '-height' => 0,
        '-width' => 0,
       );

    my $l_Shadow = $l_UR->Frame
       (
        '-background' => $l_UR->Darken ($l_UR->cget ('-background'), 50),
        '-relief' => 'flat',
        '-borderwidth' => 1,
        '-height' => 0,
        '-width' => 1,
       );

    my $l_BR = $this->Frame
       (
        '-relief' => 'flat',
        '-borderwidth' => 0,
        '-height' => 0,
        '-width' => 0,
       );

    $this->ConfigSpecs
       (
        '-buttonbackground' => [$l_ButtonContainer],
        '-buttonforeground' => [$l_ButtonContainer],
        '-buttoncommand' => [$l_ButtonContainer],
        '-selectcommand' => [$l_ButtonContainer],
        '-listforeground' => [$l_ListContainer],
        '-listbackground' => [$l_ListContainer],
        '-borderwidth' => [$l_ButtonContainer],
        '-buttoncolor' => [$l_ButtonContainer],
        '-buttonfont' => [$l_ButtonContainer],
        '-trimcount' => [$l_ButtonContainer],
	'-selectmode' => [$l_ListContainer],
        '-background' => [$l_ListContainer],
        '-foreground' => [$l_ListContainer],
        '-command' => [$l_ButtonContainer],
        '-listcolor' => [$l_ListContainer],
        '-listfont' => [$l_ListContainer],
        '-image' => [$l_ButtonContainer],
        '-zoom' => [$l_ButtonContainer],
        '-font' => [$l_ListContainer],
        '-columns' => ['METHOD'],
        'DEFAULT' => [$l_ButtonContainer],
       );

    $this->ConfigSpecs
       (
        '-command' => '-selectcommand',
        '-columnlabels' => '-columns',
        '-font' => '-listfont',
        '-bg' => '-background',
       );

    $l_ButtonContainer->ConfigSpecs
       (
        '-listbackground' => [$l_ListContainer],
        '-listforeground' => [$l_ListContainer],
        '-listselectmode' => [$l_ListContainer],
        '-listfont' => [$l_ListContainer],
       );

    $this->Delegates
       (
        'buttoncontainer' => $l_ButtonContainer,
        'SlaveUpdate' => $l_ButtonContainer,
        'columnwidth' => $l_ButtonContainer,
        'buttonwidth' => $l_ButtonContainer,
        'buttonhash' => $l_ButtonContainer,
        'Construct' => $l_ButtonContainer,
        'listhash' => $l_ButtonContainer,
        'DEFAULT' => $l_ButtonContainer,
        'buttons' => $l_ButtonContainer,
        'labels' => $l_ButtonContainer,
        'width' => $l_ButtonContainer,
        'hash' => $l_ButtonContainer,
       );

    $this->Delegates
       (
        'listcontainer' => $l_ListContainer,
        'curselection' => $l_ListContainer,
        'selection' => $l_ListContainer,
        'activate' => $l_ListContainer,
        'nearest' => $l_ListContainer,
        'lists' => $l_ListContainer,
        'size' => $l_ListContainer,
        'rows' => $l_ListContainer,
        'see' => $l_ListContainer,
       );

    $l_ListContainer->Delegates
       (
        'SlaveUpdate' => $l_ButtonContainer,
        'buttoncontainer' => $l_ButtonContainer,
        'buttons' => $l_ButtonContainer,
       );

    $l_HScrollbar->configure
       (
        '-command' => sub
           {
            $l_ButtonPane->xview (@_);
            $l_SlavePane->xview (@_);
           }
       );

    $l_ButtonPane->configure ('-xscrollcommand' => sub {$l_HScrollbar->set (@_);});
    $l_SlavePane->configure ('-xscrollcommand' => sub {$l_HScrollbar->set (@_);});
    $l_ButtonContainer->bind ('', sub {$this->CheckScrollbars();});
    $l_ListContainer->bind ('', sub {$this->CheckScrollbars();});
    $this->GridConfigure();

    $l_ButtonContainer->pack ('-side' => 'left', '-anchor' => 'nw', '-expand' => 'true', '-fill' => 'x');
    $l_ListContainer->pack ('-side' => 'left', '-anchor' => 'nw', '-expand' => 'true', '-fill' => 'both');
    $l_Shadow->pack ('-side' => 'left', '-anchor' => 'nw', '-expand' => 'false', '-fill' => 'y',);
    $l_ButtonPane->grid ('-sticky' => 'nsew', '-column' => 0, '-row' => 0);
    $l_SlavePane->grid ('-sticky' => 'nsew', '-column' => 0, '-row' => 1);
    $l_HScrollbar->grid ('-sticky' => 'nsew', '-column' => 0, '-row' => 2);
    $l_VScrollbar->grid ('-sticky' => 'nsew', '-column' => 1, '-row' => 1);
    $l_UR->grid ('-sticky' => 'nsew', '-column' => 1, '-row' => 0);
    $l_BR->grid ('-sticky' => 'nsew', '-column' => 1, '-row' => 2);

    return $this;
   }

#-----------------------------Event-Handlers----------------------------------#

sub GridConfigure
   {
    $_[0]->gridColumnconfigure ( 0, '-minsize' => 0, '-weight' => 1);
    $_[0]->gridColumnconfigure ( 1, '-minsize' => 0, '-weight' => 0);
    $_[0]->gridRowconfigure ( 0, '-weight' => 0);
    $_[0]->gridRowconfigure ( 1, '-minsize' => 0, '-weight' => 1);
    $_[0]->gridRowconfigure ( 2, '-minsize' => 0, '-weight' => 0);
   }

sub CheckScrollbars
   {
    my $l_HScrollbar = $_[0]->Subwidget ('HScroll');
    my $l_VScrollbar = $_[0]->Subwidget ('VScroll');

    if ($l_VScrollbar->Needed() && ! $l_VScrollbar->IsMapped())
       {
        $l_VScrollbar->grid ('-sticky' => 'nsew', '-column' => 1, '-row' => 1);
       }
    elsif (! $l_VScrollbar->Needed() && $l_VScrollbar->IsMapped())
       {
        $l_VScrollbar->gridForget();
       }

    if ($l_HScrollbar->Needed() && ! $l_HScrollbar->IsMapped())
       {
        $l_HScrollbar->grid ('-sticky' => 'nsew', '-column' => 0, '-row' => 2);
       }
    elsif (! $l_HScrollbar->Needed() && $l_HScrollbar->IsMapped())
       {
        $l_HScrollbar->gridForget();
       }
   }

sub NoticeChild
   {
    my ($this, $p_Child) = (shift, @_);

    return unless ($p_Child->class() eq 'ColumnButton');

    my $l_List = $this->listcontainer()->Listbox
       (
        '-highlightthickness' => 0,
        '-exportselection' => 0,
        '-borderwidth' => 0,
        '-relief' => 'flat',
       );

    $this->DoWhenIdle (['configure', $p_Child, '-slave' => $l_List]);
    $this->DoWhenIdle (['ScrollbarBind', $this]);
   }

sub ScrollbarBind
   {
    my $this = shift;

    return if (defined ($this->{'m_PrimaryList'}) && Exists ($this->{'m_PrimaryList'}));

    my $l_PrimaryList = $this->{'m_PrimaryList'} = ($this->lists())[0];
    my $l_VScrollbar = $this->Subwidget ('VScroll');

    return unless (defined ($l_PrimaryList) && defined ($l_VScrollbar));

    $l_VScrollbar->configure
       (
        '-command' => sub {$l_PrimaryList->yview (@_);}
       );

    $l_PrimaryList->configure
       (
        '-yscrollcommand' => sub {$l_VScrollbar->set (@_);},
       );
   }

#------------------------------- Private methods -----------------------------#

sub __insert
   {
    my ($this, $p_Where, @p_Data) = @_;

    my @l_ColumnList = $this->lists();
    my $l_ColumnHash = $this->hash();

    my $l_Cursor = 0;
    my @l_ColumnData;
    my %l_Indices;

    #=============================
    # Build mutual cross references
    #=============================

    foreach my $l_Key (keys %{$l_ColumnHash})
       {
        for (my $l_Index = 0; $l_Index <= $#l_ColumnList; ++$l_Index)
           {
            $l_Indices {$l_Key} = $l_Index if ($l_ColumnList [$l_Index] eq $l_ColumnHash->{$l_Key});
           }
       }

    #=============================
    # Build Columnar data arrays
    #=============================

    foreach my $l_Datum (@p_Data)
       {
        if ((ref ($l_Datum) eq 'HASH' || ref ($l_Datum) eq 'ARRAY') && $l_Cursor > 0)
           {
            while ($l_Cursor <= $#l_ColumnList)
               {
                push (@{$l_ColumnData [$l_Cursor++]}, '');
               }

            $l_Cursor = 0;
           }

        if (ref ($l_Datum) eq 'HASH')
           {
            foreach my $l_Key (keys %{$l_ColumnHash})
               {
                push (@{$l_ColumnData [$l_Indices {$l_Key}]}, $l_Datum->{$l_Key});
               }
           }
        elsif (ref ($l_Datum) eq 'ARRAY')
           {
            for (my $l_Index = 0; $l_Index <= $#l_ColumnList; ++$l_Index)
               {
                push (@{$l_ColumnData [$l_Index]}, ${$l_Datum}[$l_Index]);
               }
           }
        else
           {
            push (@{$l_ColumnData [$l_Cursor++]}, $l_Datum);
           }
       }

    while ($l_Cursor <= $#l_ColumnList && $l_Cursor > 0)
       {
        push (@{$l_ColumnData [$l_Cursor++]}, '');
       }

    #=============================
    # Insert Column data by column
    #=============================
    for (my $l_Index = 0; $l_Index <= $#l_ColumnList; ++$l_Index)
       {
        next if ($p_Where eq '');
        $l_ColumnList [$l_Index]->insert ($p_Where, @{$l_ColumnData [$l_Index]});
       }

    $this->buttoncontainer()->SlaveUpdate();
   }

sub __update
   {
    my ($this, $p_Code, @p_Contents) = (shift, @_);

    $this->__delete ($p_Code, $p_Code);
    $this->__insert ($p_Code, @p_Contents);
   }

sub __delete
   {
    my $this = shift;

    foreach my $l_Column ($this->lists())
       {
        next unless ($_[0] ne '');
        $l_Column->delete (@_);
       }
   }

#-----------------------------'METHOD'-type-settings--------------------------#

*columnlabels = \&Tk::Columns::columns;

sub columns
   {
    my $this = shift;

    foreach my $l_Item (@{$_[0]})
       {
        if (ref ($l_Item) eq 'ARRAY')
           {
            $this->addcolumn (@{$l_Item});
           }
        elsif (ref ($l_Item) eq '')
           {
            $this->addcolumn ('-text' => $l_Item);
           }
       }
   }

#------------------------------- Public methods -----------------------------#

*Column = \&Tk::Columns::addcolumn;
*Button = \&Tk::Columns::addcolumn;
*column = \&Tk::Columns::addcolumn;
*button = \&Tk::Columns::addcolumn;

sub addcolumn
   {
    return shift->ColumnButton (@_);
   }

sub insert
   {
    $_[0]->DoWhenIdle (['__insert', @_]);
   }

*replace = \&Tk::Columns::update;

sub update
   {
    $_[0]->DoWhenIdle (['__update', @_]);
   }

sub delete
   {
    $_[0]->DoWhenIdle (['__delete', @_]);
   }

sub bbox
   {
    my $l_Listbox = $_[0]->indexedlist ($_[2] || 0);

    return (defined ($l_Listbox) ? $l_Listbox->bbox ($_[1]) : ());
   }

sub get # This returns a list of references to row data arrays
   {
    my $this = shift;
    my @l_Return;

    foreach my $l_Listbox ($this->lists())
       {
        my $l_Index = 0;

        foreach my $l_Datum ($l_Listbox->get (@_))
           {
            push (@{$l_Return [$l_Index++]}, $l_Datum);
           }
       }

    return (@l_Return);
   }

sub index
   {
    my ($l_Column) = (shift->lists());

    return (defined ($l_Column) ? $l_Column->index (@_) : undef);
   }

sub indexedbutton
   {
    return
       (
        ($_[1] =~ /^[0-9][0-9]*$/ || ! defined ($_[1])) ?
        ($_[0]->buttons())[int ($_[1])] :
        $_[0]->buttonhash()->{$_[1]}
       );
   }

sub indexedlist
   {
    return
       (
        ($_[1] =~ /^[0-9][0-9]*$/ || ! defined ($_[1])) ?
        ($_[0]->lists())[int ($_[1])] :
        $_[0]->listhash()->{$_[1]}
       );
   }

1;

__END__