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", [] ); } } }
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 ###
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

In reply to My Tk::ColumnView Module by Ace128

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.