My Tk::ColumnView Module

Ace128 has asked for the wisdom of the Perl Monks concerning the following question:

Hey, a while back, I posted about this (531476). Now, I have made a really alpha version...
Testcode:

use Tk;
use Tk::ColumnView;

use Data::Dumper;

use lib ".";

use strict;
use warnings;

my $mw = new MainWindow;


#my $l1 = $pw->Label(-text => "This is the\nleft side", -background =>
+ 'yellow');
#my $l2 = $pw->Label(-text => "This is the\nright side", -background =
+>'cyan');
#my $l3 = $pw->Label(-text => "This is the\nright side", -background =
+>'cyan');

my $columnView = $mw->ColumnView(
#            -left_right_nav => sub {print "Hej\n"},
#            -columns => 1,
#            -scrollbars => 'osoe',
            -left_right_nav     => \&left_right_navigation,
            -up_down_nav        => \&up_down_navigation,
            -browsecmd  => sub {
                                my $file = shift;
                                print $file . "\n";
                                print Dumper(@_);
                           }
               )->pack(-expand => 1, -fill => 'both');

#$columnView->setOverRideLeftRightNavigation(1);

$columnView->addColumn("Root", [ "PerlMonks" ]);
$columnView->addColumn("PerlMonks", [ "Seekers of Perl Wisdom",
                                      "Meditations",
                                      "PerlMonks Discussion",
                                      "Snippets",
                                      "Obfuscation",
                                      "Reviews",
                                      "Cool Uses For Perl",
                                      "Perl News",
                                    ]
                      );
#$columnView->addColumn("Title", "./*");
#$columnView->addColumn("Title", "./*");
#$columnView->modifyColumn("Title", "./*");
#$columnView->addColumn();
$columnView->setFocusOnColunmNamed("PerlMonks");
$mw->MainLoop;


sub left_right_navigation {

    my $nav = shift;
    my $selected = shift;
    my $single_one = shift;

    if ($nav eq "left") {
        if ($columnView->getAmountOfColumns() > 2) {
            $columnView->delLastColumn();
        }
    }
    elsif ($nav eq "right") {
        $columnView->addColumn($selected);
    }

}

sub up_down_navigation {

    my $nav = shift;
    my $selected = shift;
    my $single_one = shift;

    return if (!defined($single_one));

    if ($single_one eq "Seekers of Perl Wisdom") {
        $columnView->modifyColumn("PerlMonks", [ "Why is Perl the best
+?", "What is the time?" ] );
    }
    elsif ($single_one eq "Cool Uses For Perl") {
        $columnView->modifyColumn("PerlMonks", [ "OS made in Perl", "P
+erlmodule for spacetravel"] );
    }
    else {
        if ($columnView->getAmountOfColumns() == 3) {
            $columnView->modifyColumn("PerlMonks", [] );
        }
    }
}
[download]

Module:

######################################## SOH #########################
+##################
## Function : Tk Class Using HList to view data columnwise, where one 
+can add/del more
##            columns as if it was some kind of hierarchy. Navigation 
+through these using
##            arrow keys.
##
## Copyright (c) 2006 Daniel Åkesson <danielakesson at gmail.com>. All
+ rights reserved.
##
## Thanks to B< Michael Krause> for the inspirational HListplus. :)
##
## This program is free software; you can redistribute it and/or modif
+y it
## under the same terms as Perl itself.
##
## History  : V0.1    2006-02-27  Basic Class compound extending HList
+.
######################################## EOH #########################
+##################

##############################################
### Use
##############################################
use Tk::HList;
use Tk::ItemStyle;
use Tk qw(Ev);

use strict;
use Carp;

use vars qw ($VERSION);
$VERSION = '0.1';


######################################################################
+##
package OverriddenHList;

use base qw (Tk::Derived Tk::HList);

use Data::Dumper;

Construct Tk::Widget 'OverriddenHList';


#sub ClassInit {
#    my ($class, $mw) = @_;
#    $class->SUPER::ClassInit($mw);
#}

##################################
## OVERRIDDEN

sub LeftRight {

    my $this = shift;
    my $direction = shift;

    if ($direction eq "left") {
        #$this->SUPER::LeftRight($direction);
    }
    elsif ($direction eq "right") {
    }

    $this->Callback(-left_right_nav => $direction);
 }

sub UpDown {

    my $this = shift;
    my $direction = shift;

    $this->SUPER::UpDown($direction);

    if ($direction eq "left") {
    }
    elsif ($direction eq "right") {
    }
    $this->Callback(-up_down_nav => $direction);
}



#---------------------------------------------
# internal Setup function
#---------------------------------------------
sub Populate
{
    my ($this, $args) = @_;
    $this->SUPER::Populate($args);


    #$this->SUPER::Populate($args);
    $this->ConfigSpecs(
        -left_right_nav     => [ 'CALLBACK',undef,undef, sub {}],
        -up_down_nav        => [ 'CALLBACK',undef,undef, sub {}],
        -takefocus            => [ [ 'SELF', 'PASSIVE' ], 'takefocus',
+ 'TakeFocus', 1 ],
    );
}


######################################################################
+##

package Tk::ColumnView;

#use base qw (Tk::Derived Tk::Toplevel);
use base qw (Tk::Derived Tk::Frame);

use Tk;
use Tk::Panedwindow;

use File::Basename;

use Data::Dumper;

Construct Tk::Widget 'ColumnView';

# needed to include also the aliased commands
use Tk::Submethods ( 'addColumn'    => [qw(configure cget create delet
+e exists size)] );


sub ClassInit {
    my ($class, $mw) = @_;
    $class->SUPER::ClassInit($mw);

}


#---------------------------------------------
# internal Setup function
#---------------------------------------------
sub Populate
{
    my ($this, $args) = @_;

    my $data_background = delete $args->{-databackground};
    $data_background = $this->cget ('-background') unless defined $dat
+a_background;
    $this->{m_headerstyle} = delete $args->{-headerstyle} || $this->It
+emStyle ('window', -padx => '0', -pady => '0', );

    #Invoke Superclass fill func
    $this->SUPER::Populate($args);


    $this->{PanedWindow} = $this->Component(
        'Panedwindow',
        #-background  => 'white',
        #-relief      => 'raised',
        #-borderwidth => 1,
        #-width       => 1,
        #-cursor      => 'sb_h_double_arrow',
    );

    $this->{Columns} = [];
    $this->{Name_To_Column}  = {};
    $this->{amount_columns}  = 0;
    $this->{Column_Selected} = 0;
    $this->{left_right_nav_overridden} = 0;
    $this->{up_down_overridden} = 0;

    my $pw = $this->{PanedWindow};
    $pw->pack(qw/-side top -expand yes -fill both -pady 2 -padx 2m/);

    $this->{'reqheight'} = $pw->reqheight();
    $this->{'reqwidth'}  = $pw->reqwidth();

    $this->{width} = 0;
    $this->{height} = 0;
    $this->{column_selected} = -1;

    $pw->bind( '<Configure>' => sub { $this->Configure($this); } );
    #$trim->bind( '<ButtonRelease-1>'    => sub { $this->ButtonRelease
+(1); } );
    #$trim->bind( '<ButtonPress-1>'        => sub { $this->ButtonPress
+(1); } );
    #$trim->bind( '<Motion>'             => sub { $this->ButtonOver(1)
+; } );
    #$trim->bind( '<Enter>'                => sub { $this->TrimEnter()
+; } );
    #$trim->bind( '<Leave>'                => sub { $this->TrimLeave()
+; } );

    #$this->bind( '<Enter>'                => sub { $this->TrimEnter()
+; } );

    #$trim->bind( '<Leave>'                => sub { $this->TrimLeave()
+; } );

#             # Override these ones too
#             $this->bind( '<Enter>'                    => sub { print
+ "EnterBttn\n"; $this->BttnEnter(); } );
#             $this->bind( '<Leave>'                    => sub { $this
+->BttnLeave(); } );

    #$this->SUPER::Populate($args);
    $this->ConfigSpecs(
        -column             => [ [ 'SELF', 'PASSIVE' ], 'Column', 'Col
+umn', 0 ],
        -minwidth            => [ [ 'SELF', 'PASSIVE' ], 'minWidth', '
+minWidth', 30 ],
        -command             => [ 'CALLBACK',undef,undef, sub {}],
        -browsecmd            => [ 'CALLBACK',undef,undef, sub {}],
        -left_right_nav     => [ 'CALLBACK',undef,undef, sub {}],
        -up_down_nav        => [ 'CALLBACK',undef,undef, sub {}],
           -activebackground    => [ [ 'SELF', 'PASSIVE' ], 'activebac
+kground', 'activebackground', $this->SUPER::cget(-background) ],
        -activeforeground    => [ [ 'SELF', 'PASSIVE' ], 'activeforegr
+ound', 'activeforeground', 'blue' ],
        -buttondownrelief    => [ [ 'SELF', 'PASSIVE' ], 'buttondownre
+lief', 'buttondownrelief', 'flat' ],
        -relief             => [ [ 'SELF', 'PASSIVE' ], 'relief', 'rel
+ief', 'flat' ],
        -padx                => [ [ 'SELF', 'PASSIVE' ], 'padx', 'padx
+', 0 ],
        -pady                => [ [ 'SELF', 'PASSIVE' ], 'pady', 'pady
+', 0 ],
        -anchor                => [ [ 'SELF', 'PASSIVE' ], 'Anchor', '
+Anchor', 'w' ],
        -lastcolumn            => [ [ 'SELF', 'PASSIVE' ], 'LastColumn
+', 'LastColumn', 0 ],
        #-takefocus            => [ [ 'SELF', 'PASSIVE' ], 'takefocus'
+, 'TakeFocus', 1 ],
    );
}

sub Configure {
    my $this = shift;

    my $width  = $this->width;
    my $height = $this->height;

    if ($width < 10) {
        $width = 200;
    }
    if ($height < 10) {
        $height = 300;
    }

    if ($this->{amount_Columns} == 1) {
        #print "O N E !  $width\n";
        $this->{one_width} = $width;
        $this->{one_height} = $height;
    }
    $this->{width} = $width;
    $this->{height} = $height;
    #${$this->{Columns}}[$c_selected]{'s_hlist'}->focus();
    #$this->{'PanedWindow'}->idletasks;
    $this->{'PanedWindow'}->update;
    #if ($this->{update_needed}) {
    #}
}


sub MouseMotion {

    my $this = shift;
    my $s_hlist = shift;

    #$s_hlist->toplevel->focus;
    #$s_hlist->parent->focus;
    $s_hlist->focus;
    #$s_hlist->focus() if($s_hlist->cget('-takefocus'));
    #print Dumper($s_hlist);
    #print ".";

}

sub addColumn {

    my $this   = shift;
    my $name   = shift; # Name for this Column
    my $to_add = shift; # If wanna use files and folders in list.
    my $width  = (shift || $this->{one_width} || 200);
    my $height = (shift || $this->{one_height} || 300);

    $width += $this->{width};

    #$this->{width} += $width;
    #$this->{height} = $height;

    ++$this->{amount_Columns};

    my $pw = $this->{'PanedWindow'};

    my $folderimage = $pw->Getimage("folder");
    my $fileimage   = $pw->Getimage("file");
    my $srcimage    = $pw->Getimage("srcfile");
    my $textimage   = $pw->Getimage("textfile");

    my $scrolled_hlist;
    $scrolled_hlist = $pw->Scrolled("OverriddenHList",
#            -left_right_nav => sub {print "Hej\n"},
#            -columns => 1,
            -scrollbars => 'osoe',
            -selectmode => 'extended',
            -browsecmd  => sub {
#                                my $file = shift;
#                                print $file . "\n";
#                                print Dumper(@_);
                           },
            -left_right_nav => sub { $this->_LeftRightNavigation($scro
+lled_hlist, @_) },
            -up_down_nav    => sub { $this->_UpDownNavigation($scrolle
+d_hlist, @_) },
               ); #->pack(-expand => 1, -fill => 'both');

    $scrolled_hlist->bind( '<Motion>'    => sub { $this->MouseMotion($
+scrolled_hlist); } );

    if (ref(\$to_add) eq 'SCALAR') {
        my $i = 0;
        foreach (glob($to_add)) {
            my $image;
            if (-d $_) {
                $image = $folderimage;
            }
            elsif (-f $_) {
                if (/\.(c|cpp|cc|pl)$/) {
                    $image = $srcimage;
                } elsif (/\.te?xt$/) {
                    $image = $textimage;
                } else {
                    $image = $fileimage;
                }
            }
            $scrolled_hlist->add(++$i,
                -itemtype => "imagetext",
                -text => basename($_),
                (defined $image ? (-image => $image) : ()),
            );
        }
    }
    elsif (ref($to_add) eq 'ARRAY') {
        my $i = 0;
        foreach (@{$to_add}) {
            $scrolled_hlist->add(++$i,
                -itemtype => "imagetext",
                -text => $_,
                -image => $textimage,
            );
        }

    }
    elsif (ref($to_add) eq 'HASH') {

    }

    if ($name) {
        $this->{Name_To_Column}->{$name} = $this->{amount_Columns};
    }



    push(@{$this->{Columns}}, {'s_hlist' => $scrolled_hlist, 'width' =
+> 100, 'height' => 200});

    $pw->add($scrolled_hlist);
    #$pw->packForget();
    #$pw->pack(qw/-side top -expand yes -fill both -pady 2 -padx 1m/);

    #$width += $this->{width};
    #$width -= $this->{one_width};
    $pw->toplevel->geometry(($width)."x".($this->{height}));

    #$pw->toplevel->geometry(($this->{width}+$this->{one_width})."x".(
+$this->{height}+$this->{one_height}));
    #$this->{'reqheight'} = $pw->reqheight();
    #$this->{'reqwidth'}  = $pw->reqwidth();
    if ($this->{amount_Columns} > 1) {
        $pw->sashPlace($this->{amount_Columns} - 2, $this->{one_width}
+ * ($this->{amount_Columns} - 1), 10);
    }
    #$pw->update;

       $scrolled_hlist->focus;
      #$scrolled_hlist->selectionSet(0);
    $pw->idletasks;

    ++$this->{column_selected};


    $this->{width} = $width;
    $this->{height} = $height;
}

sub delLastColumn {

    my $this  = shift;
    my $path  = shift;

    return if ($this->{amount_Columns} == 1);

    my $pw = $this->{'PanedWindow'};

    my $hlist_hash = pop(@{$this->{Columns}});
    my $s_hlist        = $hlist_hash->{'s_hlist'};
    my $s_hlist_width  = $hlist_hash->{'width'};
    my $s_hlist_height = $hlist_hash->{'height'};

    --$this->{amount_Columns};
    $this->{width} -= $this->{one_width};

    #$s_hlist->packForget();
    $pw->forget($s_hlist);
    #$pw->packForget();
    #$pw->pack(qw/-side top -expand yes -fill both -pady 2 -padx 1m/);

    #$pw->update;

    #$pw->toplevel->geometry(($this->{width}+$this->{one_width})."x".(
+$this->{height}+$this->{one_height}));
    $pw->toplevel->geometry(($this->{width})."x".($this->{height}));


    #print Dumper(${$this->{Columns}}[$this->{amount_Columns} - 1]->{'
+s_hlist'});
    $pw->update;

    $this->{column_selected} = $this->{amount_Columns} - 1;
    #${$this->{Columns}}[$this->{amount_Columns} - 1]->{'s_hlist'}->fo
+cus;
}


sub modifyColumn {

    my $this  = shift;
    my $name  = shift;
    my $data  = shift;

    #my $pw = $this->{'PanedWindow'};

    my $column_at =    $this->{Name_To_Column}->{$name};
    if ($column_at) {
        my $hlist_hash = (@{$this->{Columns}}[$column_at - 1]);
        my $scrolled_hlist = $hlist_hash->{'s_hlist'};
        my $s_hlist_width  = $hlist_hash->{'width'};
        my $s_hlist_height = $hlist_hash->{'height'};

        $scrolled_hlist->delete('all');

        if (ref(\$data) eq 'SCALAR') {
            my $i = 0;
            foreach (glob($data)) {
                my $image;
                if (-d $_) {
                    #$image = $folderimage;
                }
                elsif (-f $_) {
                    if (/\.(c|cpp|cc|pl)$/) {
                        #$image = $srcimage;
                    } elsif (/\.te?xt$/) {
                        #$image = $textimage;
                    } else {
                        #$image = $fileimage;
                    }
                }
                $scrolled_hlist->add(++$i,
                    -itemtype => "imagetext",
                    -text => basename($_),
                    (defined $image ? (-image => $image) : ()),
                );
            }
        }
        elsif (ref($data) eq 'ARRAY') {
            my $i = 0;
            foreach (@{$data}) {
                $scrolled_hlist->add(++$i,
                    -itemtype => "imagetext",
                    -text => $_,
                    #-image => $textimage,
                );
            }

        }
        elsif (ref($data) eq 'HASH') {

        }

        #$hlist_hash->{'s_hlist'}->update;
        #$this->{'PanedWindow'}->update;

        #$pw->toplevel->geometry(($this->{width}-$this->{one_width})."
+x".($this->{height}));
    }
}

sub getAmountOfColumns {

    my $this = shift;
    return $this->{amount_Columns};
}


sub _LeftRightNavigation {

    my $this = shift;
    my $s_hlist = shift;
    my $direction = shift;

    my $c_selected = $this->{column_selected};

    my $this_hlist = "";
    my @s_hlist_row_selected = $s_hlist->selectionGet();
    if (@s_hlist_row_selected > 0) {
        $this_hlist = $s_hlist->entrycget($s_hlist_row_selected[0], -t
+ext);
    }
    else {
        if (!$this->{left_right_nav_overridden}) {
            return;
        }
    }

    my $path = "";
    foreach (@{$this->{Columns}}) {

        my $s_hlist = $_->{'s_hlist'};
        my @s_hlist_row_selected = $s_hlist->selectionGet();
        if (@s_hlist_row_selected > 0) {
            $path .= $s_hlist->entrycget($s_hlist_row_selected[0], -te
+xt) . ",";
        }
    }
    $path =~ s/,$//;


    $this->Callback(-left_right_nav => $direction, $path, $this_hlist)
+;

    #print Dumper($s_hlist);


    if ($direction eq "left") {
        --$c_selected;
        if ($c_selected < 0) {
            $c_selected = 0;
        }
        ${$this->{Columns}}[$c_selected]{'s_hlist'}->focus();
        #${$this->{Columns}}[$c_selected]{'s_hlist'}->selectionClear()
+;
        #${$this->{Columns}}[$c_selected]{'s_hlist'}->selectionSet(1);
        #${$this->{Columns}}[$c_selected]{'s_hlist'}->see(1);
    }
    elsif ($direction eq "right") {
        ++$c_selected;
        if ($c_selected >= @{$this->{Columns}}) {
            --$c_selected;
        }
        ${$this->{Columns}}[$c_selected]{'s_hlist'}->focus();
        #${$this->{Columns}}[$c_selected]{'s_hlist'}->selectionClear()
+;
        #${$this->{Columns}}[$c_selected]{'s_hlist'}->selectionSet(1);
        #${$this->{Columns}}[$c_selected]{'s_hlist'}->see(1);

    }
    $this->{column_selected} = $c_selected;
    #print "C_SEL: $c_selected\n";
}


sub setOverRideLeftRightNavigation {

    my $this = shift;
    $this->{left_right_nav_overridden} = shift;
}


sub _UpDownNavigation {

    my $this = shift;
    my $s_hlist = shift;
    my $direction = shift;

    my $c_selected = $this->{column_selected};

    my $this_hlist = "";
    my @s_hlist_row_selected = $s_hlist->selectionGet();
    if (@s_hlist_row_selected > 0 && !$this->{up_down_nav_overridden})
+ {
        $this_hlist = $s_hlist->entrycget($s_hlist_row_selected[0], -t
+ext);
    }
    else {
        if (!$this->{up_down_nav_overridden}) {
            return;
        }
    }

    my $path = "";
    foreach (@{$this->{Columns}}) {

        my $s_hlist = $_->{'s_hlist'};
        my @s_hlist_row_selected = $s_hlist->selectionGet();
        if (@s_hlist_row_selected > 0) {
            $path .= $s_hlist->entrycget($s_hlist_row_selected[0], -te
+xt) . ",";
        }
    }
    $path =~ s/,$//;


    $this->Callback(-up_down_nav => $direction, $path, $this_hlist);
}

sub setOverRideUpDownNavigation {

    my $this = shift;
    $this->{up_down_nav_overridden} = shift;
}


sub setFocusOnColunmAt {

    my $this = shift;
    my $column_at = shift;

    return if (!defined($column_at));
    return if ($column_at < 0);
    return if ($column_at > @{$this->{Columns}});

    ${$this->{Columns}}[$column_at]{'s_hlist'}->focus();
}


sub setFocusOnColunmNamed {

    my $this = shift;
    my $column_named = shift;

    return if (!defined($column_named));
    return if (length($column_named) < 1);

    if (!exists($this->{Name_To_Column}->{$column_named})) {
        warn "Column named: \"" . $column_named . "\" doesn't exist!\n
+";
        return;
    }

    my $c_selected = $this->{Name_To_Column}->{$column_named - 1};
    #print "C: $c_selected\n";
    $this->{column_selected} = $c_selected;
    ${$this->{Columns}}[$c_selected]{'s_hlist'}->focus();
    ${$this->{Columns}}[$c_selected]{'s_hlist'}->update;
    #$this->{'PanedWindow'}->update;


}

######################################################################
+##

1;
__END__

###
### EOF
###
[download]

Ok, first off. What you guys think? :) Secondly I have some questions.

1. If I press down, I get this - - - selection around (including the "raised" selection you get if you click in the list. Why do I have to press down once, even if I have set the selected using selectionSet? (the idea else if to select the first one in the HList (if there is any)) Its like its selected but not. Or, like if there are two different "selected" notifications... "raised" are selected and the - - - - surrounded is the one currently marked. Im kinda confused about this, since I dont get how to set the currently selected... Well, feel free to modify the module for the better...

2. If I press and hold the right arrow on the keyboard (using fast repeat), several columns can be added and the whole thing goes out of "sync" (focus on the wrong one). Ideas how to fix this?

And note also, this is really early "release". Just wanted to make it as fast as I could, since I have other things to do...

Ace

Comment on My Tk::ColumnView Module Select or Download Code

Replies are listed 'Best First'.
Re: My Tk::ColumnView Module by zentara (Cardinal) on Feb 27, 2006 at 20:49 UTC
Could you possible set up a running example, with some sample data? I'm not really a human, but I play one on earth. flash japh	[reply]
Re^2: My Tk::ColumnView Module by Ace128 (Hermit) on Feb 28, 2006 at 07:21 UTC
Uh, I did! "Testcode" tests the Tk::ColumnView module! That is, first script should be able of runing the module mentioned second. So, save the first script into a dir. Second as ColumnView.pm in the <same dir>/Tk/, and run the test script. UPDATE: Seems like the - - - - is set by $hlist->anchorSet! Nice! :)	[reply]
Re: My Tk::ColumnView Module by zentara (Cardinal) on Feb 28, 2006 at 12:52 UTC
To be honest, I can't figure out what it is supposed to do, and why it is superior over some other widget. When I run it, and press the arrow keys, it just changes somehow, but I can't see any pattern to it, so it seems broken to me. I press the down arrow, and the column text changes, to "Why is Perl the best"; if I hit the right arrow, a new box appears with ./ in it. but I can't edit it or anything. ??? Sorry, it may be a rudimentary version, and creating the new box, with built-in adjuster seems cool, but I can't see what I would use it for. I'm not really a human, but I play one on earth. flash japh	[reply]
Re^2: My Tk::ColumnView Module by Ace128 (Hermit) on Mar 01, 2006 at 06:54 UTC
Heh, ok, I can do some explaning. If you used MacOSX's Finder in column view you can probably skip this though, since this is what this is supposed to be (and more). The idea with this is to have some kind of grouping (or tree hierarchy - where the left is the parent of the one to the right). So, when you go to the right you go down into the tree. Music is a good example. Where, say, you have Genre at the top, and thus, this is put on the leftmost side. Genres consist among others of Pop, Rock and Trance. These are then inserted right of the Genre column. We have: `Col #1 Col #2 Col #3 ... [Genre] -> Pop Rock Trance` [download] Natrually, the widget is dynamic, so if we are in the second column, and pick for instance the "Rock" row, we can next to that (in the third column add/modify what we wanna have there), in realtime. Thus we can have: `Col #1 Col #2 Col #3 ... [Genre] -> Pop Queen [Rock] etc Trance ...` [download] Myself is gonna use this for searching. And this is a good way grouping the result. And more to the point, really nice browsing through the data!	[reply] [d/l] [select]