UPDATE 3pm EST Mar 31,2006. Condensed some redundant code into subs, and fixed a special case bug so you can launch from the topmost dir, / (on linux) or C:/, D:/, etc( on windows ). Also added a static topdir indicator arrow. April 1 -> Added a Busy cursor for slow machines and big subdir trees. Made topdir arrow indicator active color for better visibility.

UPDATE APR 5,2006 .. This is the last update for this package before I turn it into a module. I added the ability to configure all options with ConfigSpecs, cleaned up some code, and improved the example in main. Run this for 30 seconds, and let it do it's thing :-)

This is a Derived Tk Canvas widget to display a directory tree with animations like those used in the Gtk2 Tree. It has the ability to use a background image, which can be a Tk Photo object, or a jpg/png/gif file. This is on its way to becoming a module. It has been briefly tested on Windows, and it works there as well as on linux. I would appreciate any feedback about any bugs found, or code improvements, with an outlook towards its usability as a module. Some of the "windows compatibility code" may not be needed, but I found it easiest just to convert all backslashes to forward slashes. Thanks to Christoph Lamprecht ( he must be a monk :-) ) for showing me how to make the correct bindings to a Derived Canvas... it's a major stumbling block, and this code may well be worth it, just for demonstrating derived canvas bindings.

Just run it in a directory with some subdirs in it. It will only delve 2 layers deep at a time, so it will work fairly well on huge trees. It has easy single click bindings ( I hate double-click widgets :-) )

You can set your background image from the main script (at the bottom). I've included a base64 encoded image just for this demo. The main script dosn't do much with the selected directory, other than print it out. What you do with the directory is up to you, like displaying any images in it, or selectively filtering files, etc. 

#!/usr/bin/perl

package CanvasDirTree;
use warnings;
use strict;

use Tk::widgets qw/Canvas/;
use base  qw/Tk::Derived Tk::Canvas/;
use File::Spec;
use Tk::JPEG;
use Tk::PNG;


Construct Tk::Widget 'CanvasDirTree';

sub ClassInit
{
    my ($class, $mw) = @_;
    $class->SUPER::ClassInit($mw);
    $mw->bind($class, "<1>" =>'pick_one' );
    return $class; 
}

sub bind{
   my $self = shift;
   $self->CanvasBind(@_);
}

sub ConfigChanged {
  my ($self,$args)= @_;
  
   foreach my $opt (keys %{$args} ){
 
          if( $opt eq '-indfilla' ){ 
                    $self->{'indfilla'} = $args->{$opt};       

            my @items = $self->find('withtag','open');
             foreach my $item (@items){
                 $self->itemconfigure($item, -fill => $args->{$opt});
                      }
         };

          if( $opt eq '-indfilln' ){ 
                $self->{'indfilln'} = $args->{$opt};       
                    
            my @items = $self->find('withtag','ind');
             foreach my $item (@items){
                my @tags = $self->gettags($item);
                if( grep {$_ eq 'open'} @tags ){next} 
                $self->itemconfigure($item, -fill => $args->{$opt});
                      }
                  };  
       #---------------------------------------------
    
       #----------- fontcolor updates--------------
          if( $opt eq '-fontcolora' ){ 
                    $self->{'fontcolora'} = $args->{$opt};       
            $self->itemconfigure('list', -activefill => $args->{$opt})
+;
                 };
        
          if( $opt eq '-fontcolorn' ){ 
                $self->{'fontcolorn'} = $args->{$opt};       
                    $self->itemconfigure('list', -fill => $args->{$opt
+});
                  };  
        #---------------------------------------------

       #----------- background image updates--------------
          if(( $opt eq '-backimage' ) or ( $opt eq '-imx' ) or ( $opt 
+eq '-imy' )){ 
                   my $chipped = $opt;
               substr $chipped, 0, 1, '' ;  #chip off - off of $opt
               $self->{ $chipped } = $args->{$opt};       
            $self->set_background( 
                      $self->{'backimage'} ,$self->{'imx'}, $self->{'i
+my'}
                 );  
         };
       #---------------------------------------------
   }
  
$self->idletasks;

} #end config changed   
    
#################################################################
sub Populate {
   my ($self, $args) = @_;
  #-------------------------------------------------------------------
   #take care of args which don't belong to the SUPER, see Tk::Derived
   foreach my $extra ('backimage','imx','imy','font','indfilla',
                      'indfilln','fontcolorn','fontcolora') {
       my $xtra_arg = delete $args->{ "-$extra" };  #delete and read s
+ame time 
     if( defined $xtra_arg ) { $self->{$extra} = $xtra_arg }
   }
   #-----------------------------------------------------------------

    $self->SUPER::Populate($args);   

    $self->ConfigSpecs(
     -indfilla => [ 'PASSIVE', undef, undef , undef],  # need to set d
+efaults
     -indfilln => [ 'PASSIVE', undef, undef, undef],   # below for unk
+nown
     -fontcolora => [ 'PASSIVE', undef, undef, undef], # reason ??
     -fontcolorn => [ 'PASSIVE', undef, undef, undef], #
     -backimage => [ 'PASSIVE', undef, undef, undef],
     -imx => [ 'PASSIVE', undef, undef, undef],
     -imy => [ 'PASSIVE', undef, undef, undef],
     -font =>[ 'PASSIVE', undef, undef, undef]
    ); 
    
     #set some defaults
     $self->{'indfilla'} ||= 'red';        
     $self->{'indfilln'} ||= 'blue'; 
     $self->{'fontcolorn'} ||= 'black';
     $self->{'fontcolora'} ||= 'red';
     $self->{'backimage'} ||= '';        
     $self->{'imx'} ||= 0; 
     $self->{'imy'} ||= 0;
     $self->{'font'} ||= 'system';


#---determine font spacing by making a capital W---
   my $fonttest =  $self->createText(0,0,
              -fill    => 'black',
              -text    => 'W',            
              -font => $self->{'font'},
              );
   
    my ($bx,$by,$bx1,$by1) = $self->bbox($fonttest);
    $self->{'f_width'} = $bx1 - $bx;
    $self->{'f_height'} = $by1 - $by;
    $self->delete($fonttest);
#--------------------------------------------------

   $self->make_trunk('.', 0); 
 } # end Populate

########################################################
sub adjust_background{
   my ($self, $photo_obj ) = @_;   
  
   $self->delete( $self->{'background'} );
  
   $self->{'bimage'} =  $photo_obj;
   $self->{'bimg_w'} = $self->{'bimage'}->width;
   $self->{'bimg_h'} = $self->{'bimage'}->height;

   $self->{'background'} = $self->createImage( 
         $self->{'imx'}, $self->{'imy'},
          -anchor => 'nw',
         -image  => $self->{'bimage'},
    );
 
 $self->lower($self->{'background'}, 'list');
 $self->lower($self->{'background'}, 'ind');
 
 }
############################################################
sub set_background{
    my( $self, $image ,$xim, $yim) = @_;     
        
    $self->{'backimage'} = $image;
    $self->{'imx'} = $xim; 
    $self->{'imy'} = $yim;

    if( ref $image eq  'Tk::Photo'){
           $self->adjust_background($image)
    }else{ 
          my $photo_obj =  $self->Photo( -file => $self->{'backimage'}
+ );
          $self->adjust_background( $photo_obj ); 
     }
}
##############################################################
sub get_subdirs{
  my ($self, $dir) = @_;


   if( length $self->{'backimage'} > 0 ){
       $self->set_background( 
            $self->{'backimage'},$self->{'imx'}, $self->{'imy'}
        );  
     }

    my @subdirs;
    opendir my $dh, $dir or warn $!;

    while ( my $file = readdir($dh) ) {
        next if $file =~ m[^\.{1,2}$];
         if(-d "$dir/$file"){ 
           push @subdirs, $file;       
       }else{ next }
     }

  return @subdirs;
}
###########################################################
sub check_depth_2{
   my ($self, $abs_path) = @_;
    
   my $put_ind = 0;
    opendir my $dh, $abs_path or warn $!;
       while ( my $file = readdir($dh) ) {
         next if $file =~ m[^\.{1,2}$];
             if(-d "$abs_path/$file"){ 
                 $put_ind = 1;
                 last;        
               }
        }
 return $put_ind;
}
#############################################################
sub make_trunk{
   my ($self, $dir, $level) = @_;
   my $x = 5; my $y = $self->{'f_height'};

   my @subdirs = $self->get_subdirs( $dir  ); 
   my $abs_root = File::Spec->rel2abs( $dir );
   #for windows compat
   $abs_root =~ tr#\\#/#; 

   #handle special case when toplevel is / or C:/, D:/, etc
   if($abs_root eq '/'){$abs_root = ''}
   #for windows compat
   if ( $abs_root =~ m#^([ABCDEFGHIJKLMNOPQRSTUVWXYZ])\:\/$#  )
               {$abs_root = "$1:"} 

   #add a static entry for the topdir 
   my $root_tag;
   if($abs_root eq ''){$root_tag = '/'}else{ $root_tag = $abs_root }
   my $root = $self->createLine(
           $x , $y - .8 * $self->{'f_height'},
           $x + $self->{'f_height'}, $y - .8 * $self->{'f_height'},
           $x + $self->{'f_height'}, $y - .4 * $self->{'f_height'},
             -width => int( $self->{'f_height'} / 6),
             -fill    => $self->{'fontcolora'},
             -activefill => $self->{'fontcolora'},
             -activewidth => int( $self->{'f_height'} / 6) + 1,
              -arrow => 'last',
             -arrowshape => [5,5,2],
             -tags => ['list', $root_tag,],
           );

   my $max = scalar (@subdirs);
   my $count = 0;
  
    foreach my $subdir ( sort @subdirs ){
          my $abs_path = "$abs_root/$subdir";
          #see if any depth 2 subdir exists
          my $put_ind = $self->check_depth_2($abs_path);      
     
       #make open indicator if a dir ---------------------------------
+-----     
       if( $put_ind ){
     my $ind = $self->createPolygon(
               $x + .1 * $self->{'f_width'} ,  $y + $y * $count - .3 *
+ $self->{'f_height'}, 
               $x +  .5 * $self->{'f_width'},  $y + $y * $count,
           $x + .1 * $self->{'f_width'},  $y + $y * $count + .3 * $sel
+f->{'f_height'} ,
          
           -fill    => $self->{'indfilln'},
                   -activefill => 'yellow',
           -outline => 'black',
           -width   => 1,
           -activewidth => 2,
                   -tags =>  ['ind', $abs_path], 
               );
    }
#------------------------------------------------------------
     my $id = $self->createText(
               $x + .8 * $self->{'f_width'}, $y + $y * $count + (.5 *$
+self->{'f_height'}),
               -fill    => $self->{'fontcolorn'},
           -activefill => $self->{'fontcolora'},
                   -text    => $subdir,            
               -font => $self->{'font'},
               -anchor => 'sw',
               -tags => ['list', $abs_path], 
        );
    $count++;
   }

    my ($bx,$by,$bx1,$by1)= $self->bbox('all');
    
    $self->configure(
                -scrollregion =>[0,0,$bx1,$by1]
         );
    
} # end make_trunk 
######################################################################
+######    
sub pick_one {
     my ($self) = @_;
     my $item = $self->find('withtag','current'); #returns aref
     my @tags = $self->gettags($item->[0]);
     $item = $item->[0];

     $self->{'selected'} = ''; #default is no selection

     if( grep { $_ eq 'ind' } @tags ){
        my $opened = 0;
        if( grep { $_ eq 'open'} @tags){$opened = 1}    
        @tags =  grep { $_ ne 'ind' and  $_ ne 'current' and $_ ne 'op
+en'} @tags;
        my $dir = $tags[0];

       if( $opened ){
               $self->dtag('current', 'open' );
               $self->rotate_poly($item, -90, undef,undef);
               $self->itemconfigure($item, 'fill' => $self->{'indfilln
+'} );
               $self->idletasks;
           $self->close_branch($dir,$item);
        }else{
           $self->addtag('open', 'withtag', 'current'  );
           $self->rotate_poly($item, 90, undef,undef);
               $self->itemconfigure($item, 'fill' => $self->{'indfilla
+'} );
               $self->idletasks;       
           $self->add_branch($dir);
            }
   }else{
         #picked up an indicator click by this point
         #clicks on list items will be handled by get_selected
         @tags =  grep { $_ ne 'list' and  $_ ne 'current'} @tags;
         $self->{'selected'} = $tags[0];
         $self->{'selected'} ||= '';
     }
          
} # end pick_one    
####################################################################
sub get_selected{
   my ($self) = @_;
   return $self->{'selected'};
}
###################################################################
sub add_branch{
   my ($self, $abs_path) = @_;
   $self->Busy;
  
 #for windows compat
   $abs_path =~ tr#\\#/#; 

   my $item;
   foreach my $it( $self->find('withtag', $abs_path)  ){
         my @tags =  $self->gettags($it);     
         if( grep { $_ eq 'list'} @tags ){ $item = $it }
     }
    
   my ($bx,$by,$bx1,$by1)= $self->bbox($item);
   my $x = $bx + $self->{'f_width'};
   my $y_edge = ($by + $by1)/2;
   my $y = $by1;
   my $count = 0;

   my @subdirs = $self->get_subdirs( $abs_path );  
      
   my $max = scalar @subdirs;
   my $max_add = $max * $self->{'f_height'};

   $self->make_space($y_edge,$max_add);

   # add sub entries
    foreach my $subdir (sort @subdirs  ){
        my $abs_path1 = File::Spec->rel2abs("$abs_path/$subdir");
        #for windows compat
        $abs_path1 =~ tr#\\#/#; 
        #see if any depth 2 subdir exists
        my $put_ind = $self->check_depth_2($abs_path1);      
      
      #make open indicator--------------------------------------------
+-     
       if( $put_ind ){
     my $ind = $self->createPolygon(
              $x - .9 * $self->{'f_width'} , .5*$self->{'f_height'}+ $
+y + $self->{'f_height'}* $count - .3 * $self->{'f_height'}, 
              $x -  .5 * $self->{'f_width'}, .5*$self->{'f_height'}+ $
+y + $self->{'f_height'}* $count,
          $x - .9 * $self->{'f_width'},  .5*$self->{'f_height'}+ $y + 
+ $self->{'f_height'}* $count + .3 * $self->{'f_height'} ,
          
           -fill    => $self->{'indfilln'},
                   -activefill => 'yellow',
           -outline => 'black',
           -width   => 1,
           -activewidth => 2,
                   -tags =>  ['ind', $abs_path1], 
               );

    }
#------------------------------------------------------------
     my $id = $self->createText(
                $x , $y + $self->{'f_height'} * ($count + 1),
               -fill    => $self->{'fontcolorn'},
           -activefill => $self->{'fontcolora'},
                   -text    => $subdir,            
               -font => $self->{'font'},
               -anchor => 'sw',
            #   -tags => ['list',$abs_path, $abs_path1], 
           -tags => ['list', $abs_path1], 
        );
    
    #add tag to upstream indicator
    
    $count++;
   }

  $self->Unbusy;

    ($bx,$by,$bx1,$by1)= $self->bbox('list');
    $self->configure(
                -scrollregion =>[0,0,$bx1,$by1],
         );
    
} # end add_branch 
######################################################################
+######    
sub close_branch{
  my($self, $abs_path, $ind ) = @_;

  my @y; my $x;

   foreach my $it( $self->find('all')  ){

         my @tags =  $self->gettags($it);     

     if( grep { $_ eq 'current'} @tags ){next}
         if( grep { $_ eq $abs_path } @tags ){next}
         if( grep { $_ =~ /^$abs_path(.*)/ } @tags ){
             shift @tags; #shift off ind or list tag           

          if(scalar @tags > 0 ){
                my ($bx,$by,$bx1,$by1)= $self->bbox( $tags[0] );
            push @y,$by; 
            push @y,$by1;   
            $self->delete($it);      
             }
          }
    }
     
  my @sorted = sort {$a<=>$b} @y ;
  my $amount = $sorted[-1] - $sorted[0];
  my ($bx,$by,$bx1,$by1)= $self->bbox('all');
 
  my @items = $self->find('enclosed',
          $bx,  $sorted[-1] - $self->{'f_height'} , 
      $bx1, $by1 + $self->{'f_height'} ); 
 
  foreach my $move (@items){
      $self->move($move,0, -$amount);
   }

#adjust scroll region
   #$c->configure(-scrollregion => [$c->bbox('all')]);    
   ($bx,$by,$bx1,$by1)= $self->bbox('list');
    $self->configure(
                -scrollregion =>[0,0,$bx1,$by1],
         );

}
######################################################################
+########
sub make_space{
 my ($self, $y, $amount) = @_;
  
  my ($bx,$by,$bx1,$by1)= $self->bbox('all');
 
  my @items = $self->find('enclosed',$bx,$y,$bx1,$by1 + $self->{'f_hei
+ght'}); 
  
  foreach my $move (@items){
      $self->move($move,0,$amount);
   }

}
######################################################################
+########


sub rotate_poly {
    my ($self, $id, $angle, $midx, $midy) = @_;
    
    # Get the old coordinates.
    my @coords = $self->coords($id);

    # Get the center of the poly. We use this to translate the
    # above coords back to the origin, and then rotate about
    # the origin, then translate back. (old)

    ($midx, $midy) = _get_CM(@coords) unless defined $midx;

    my @new;

    # Precalculate the sin/cos of the angle, since we'll call
    # them a few times.
    my $rad = 3.1416*$angle/180;
    my $sin = sin $rad;
    my $cos = cos $rad;

    # Calculate the new coordinates of the line.
    while (my ($x, $y) = splice @coords, 0, 2) {
    my $x1 = $x - $midx;
    my $y1 = $y - $midy;

    push @new => $midx + ($x1 * $cos - $y1 * $sin);
    push @new => $midy + ($x1 * $sin + $y1 * $cos);
    }

    # Redraw the poly.
    $self->coords($id, @new);
}
#################################################################
# This sub finds the center of mass of a polygon.
# I grabbed the algorithm somewhere from the web.
# I grabbed it from Slaven Reszic's RotCanvas :-)
sub _get_CM {
    my ($x, $y, $area);

    my $i = 0;

    while ($i < $#_) {
    my $x0 = $_[$i];
    my $y0 = $_[$i+1];

    my ($x1, $y1);
    if ($i+2 > $#_) {
        $x1 = $_[0];
        $y1 = $_[1];
    } else {
        $x1 = $_[$i+2];
        $y1 = $_[$i+3];
    }

    $i += 2;

    my $a1 = 0.5*($x0 + $x1);
    my $a2 = ($x0**2 + $x0*$x1 + $x1**2)/6;
    my $a3 = ($x0*$y1 + $y0*$x1 + 2*($x1*$y1 + $x0*$y0))/6;
    my $b0 = $y1 - $y0;

    $area += $a1 * $b0;
    $x    += $a2 * $b0;
    $y    += $a3 * $b0;
    }

    return split ' ', sprintf "%.0f %0.f" => $x/$area, $y/$area;
}

1;
######################################################################
+#


######################################################################
+#
package main;
use warnings;
use strict;
use Tk;

my $mw = MainWindow->new();

$mw->fontCreate('big',
          -family=>'arial',
          -weight=>'bold',
          -size=>int(-18*18/14));

my $frame = $mw->Frame()->pack(-expand=>1,-fill=>'both');

# base64encoded png 
my $bunny = $mw->Photo(-data => 
'iVBORw0KGgoAAAANSUhEUgAAAB4AAAAjEAIAAABcJvHFAAAACXBIWXMAAAsSAAALEgHS3
+X78AAAD
F0lEQVR42u1YL+yqUBj1vfcLbhY3C44is8BIREYSG9FoNBqNkok2aFhp2BhJDWyadCZN/i
+lOGxan
jRdOuRsPxl/f+23vJKfX7x6+73znu5dK5RviV9QPDMMwDIPP7/f7/X6XTWU0Go1Go06n0+
+l0PM/z
PC91CNu2bduWZVmW5bLpjsfj8XgcBEEQBJPJZDKZZAw0n8/n8zkCGYZhGIYgCIIgFEt3OB
+wOh8OA
gKZpmqZlDDedTqfTKRnO933f95GVer1er9fz0BVFURRFxCR3QfyMQfv9fr/fDyLgOI7jON
+mo419k
JUkMBoPBYJCRNBrxdrvdbrco6qvVarVaIWdFpQO/5tIcFBbE4nQ6nU6nJIpHjlGlEklTFE
+VRFDIa
T32/3+/3+3jqHMdxHBcfB2sK6HFFURRFeb1er9crfksoNUrr0GvUfxGfnA+FmX+QALDItG
+LDA6O2
pQyCJFkPqxMDK2p9LodOAhQaLRjfoKRGo2wObl3G8PoDsA0Gb5Q5oonjfSNKTh96AOh+u9
+1ut1uS
FuZrONPJ7bJ06tA9TDDsD6QkCnDltEDRkV1Q9AnENyuk8hcyChkkcZKo5uv1er1er3S6cA
+PkFXSx
MQodPrXFg2zTEsVANhO2JNdEmVo80ub7K/lSDHPyLkNaXrVarVar2W46LMuyLFsKaZ7neZ
+4nvwFR
NGKeGjYajUajkXz9z+RLn8/n8/ms/ANIQXq5XC6Xy/v9fr/fvw3p9Xq9Xq9VVVVV9fF4PB
+6Pokhc
r9fr9Vr6s6Lf4dNpbS6/exQA3BHDt/fkPl3wwT85wlcEcrCHZyHO1tmOSl95iGLcQN80Td
+M0jTa1
LMuyLF3XdV03TdM0zWaz2Ww2Xdd1XRenDlDHgTbtvj/ykMZpDm/6LpfL5XLBmGi32+12G6
+Th5RAA
Pne73W63iwfGYFosFovF4kOZrtVqtVoN16TD4XA4HPAAKDp5yZUkSZIk1GGz2Ww2m91ut9
+vt0Mof
lcfxeDwej7PZbDaboRFbrVar1SJfIsLdYZfn8/l8Pue3y1zyiH9VAMFElb5Yp/+PcvAbH/
+25ox5S
PYYAAAAASUVORK5CYII=');


my $tux = $mw->Photo(-data =>
'/9j/4AAQSkZJRgABAQIASABIAAD/2wBDAAgGBgcGBQgHBwcJCQgKDBQNDAsLDBkSEw8UH
+RofHh0a
HBwgJC4nICIsIxwcKDcpLDAxNDQ0Hyc5PTgyPC4zNDL/2wBDAQkJCQwLDBgNDRgyIRwhMj
+IyMjIy
MjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjL/wAARCAA8AE
+MDASIA
AhEBAxEB/8QAHAAAAgIDAQEAAAAAAAAAAAAAAAQFBwIDCAYB/8QAMBAAAQMCBQMCBQMFAA
+AAAAAA
AQIDBAARBQYSITEHUXETYSIyQUKBFTOhI1KRscH/xAAaAQEBAQADAQAAAAAAAAAAAAAAAQ
+IDBQYE
/8QAIxEAAgEDAwQDAAAAAAAAAAAAAAECAwQREyExBRJBkVFSof/aAAwDAQACEQMRAD8Ap5
+brjgSF
uLUEgBIUomwACRb8ADwB2rCl5bymWgU8k2v2oiyPWGk/OP5oBiiilYkbEsanCJhsZ+S8r5
+Wo6CtR
97DegGqKZw3LWZpk6RDYwiY69GIS+0WiFNk8A34J+gPNaHW3GHVtPIU242opWhYsUkcgg8
+GgNa3E
Nga1AXr6CFC4NxUXKe9Z24+UbCm4CiWSD9DtQE07jmKvurdXiMrUo3Ol0pA8AbAew2FFR9
+FY0ofV
F7n8is9N2QexqPQstrCk8ipd1HqNKR3FQ6klKikixFbIS3qhcYuJ/tJ8V7LpFjWV8Pm4rh
+2aU6Yu
JMJZD11AJsoK0lSTqAJA3Haq9Ze0sutk7Ebb/WiEtpucwt9OppKwVp7i+9R8A6jVO/Ucfm
+TGMBZm
YEsxnI6npBaccdZvpeSLG4sQAFEXCQeDVV9a1uzsyJxVjBZUGO6wht5x1KbLdBVc3SSPl0
+jm/wAN
WejGn3mmpGH4Yqdh7qApp2K+gK8FKym1uOT+K8x1CzNHiZUmQMSYaRMmJ0sRQ6HFJTt8a7
+CwII2t
fgb828pa9avalyoSgmm+E91++POV6OzqWlGNPKb29FA1KQkaI4J+43qOab9V1KO53qZAsA
+BwK9Yd
YFFZBtZFwhVvFFTKGDGkpse49VPP3Cnaxct6ar8WNUELW+HEkT5bUSK0t191QQ22gXKiTY
+ACtFWR
0LQ0vqnh/qtayG3Sg2uEq9NW/wDugLEyX0XzHBw0KxDM8jDC4NRiRPj0+VXtfwD5rxHVLp
+PiOUo/
64nE14nDccCHXHEkONqPGrc3B7966qqMzBgcPMuAy8HnhRjSkaVaDYixBBHuCAfxWFTgpO
+SW7K5N
rBxFAaGlTvJ48U7Tmasrzsi5qfwmbct31NPWsHWz8qh/33BFJ1shaLs7qHiTpmwoOMRoz/
+8AUbai
IfDQB3ukEnY882322tRUE9nTMDjzjjeKS46VqKvSYkOIQm+5skKsB7DaigPF0vMVpjH32p
+ik8Q/b
R5oCPrq3ofktnL+UGsYebviOJoDhUoboa+1I87KPe47VyvHSFyWkngrAP+a71jR24kVmMy
+nS0yhL
aE9kgWAoDbRRRQFc9ZsnR8zZJkzUpAn4W2qSy59SgC60n2IF/IHvXLkVZcjpJ5GxrrzqfN
+dgdM8f
fZ06zFLXxC+yyEH+FGuQIP7Fve9AW9Iw+JIfU7h+TJaoqrFsuy1sqO290FSrb3+p7+1FQK
+HXEoAW
UuqAtrW2gqPnaivld3BPGGcmkz//2Q==');


my $ztree = $frame->Scrolled('CanvasDirTree',
            -bg =>'lightblue',
            -width =>300,  
        -height =>300, 
#        -backimage => 'bridget-5a.jpg',  #either a file
        -backimage => $bunny,  #or Tk::Photo object data
        -imx => 200,           # position relative to nw corner
        -imy => 10,            # to place nw corner of image
        -font => 'big',        # defaults to system
#        -fontcolorn => 'cyan', # defaults to black
#        -fontcolora => 'lightseagreen', #defaults to red
#        -indfilln => 'hotpink',         #defaults to blue   
#        -indfilla => 'orange',          #defaults to red
            -scrollbars =>'osw',
            )->pack(-side=>'left',-fill=>'both', -expand=>1); 

my $text = $frame->Scrolled('Text',
                       -bg=>'white',
               -width => 40,
               -scrollbars =>'osoe',
    )->pack(-side=>'right',-fill=>'both',-expand=>1);

my $button = $mw->Button(-text=>'Exit',-command=>sub{exit})->pack();

$ztree->bind('<ButtonPress-1>', sub{   
               my $selected = $ztree->get_selected();

            if(length $selected){
                $text->insert('end',"$selected\n");
                $text->see('end');
             }
       });


$mw->after(10000, sub{ $ztree->configure('-indfilla' => 'green' );
                       $ztree->configure('-indfilln' => 'black'); 
                       $ztree->configure('-fontcolora' => 'orange');
               $ztree->configure('-fontcolorn' => 'purple'); 
                       $ztree->configure('-bg' => 'white'); 
            });

$mw->after(15000, sub{ $ztree->configure('-indfilla' => 'red' );
                       $ztree->configure('-indfilln' => 'orange'); 
                       $ztree->configure('-fontcolora' => 'white');
               $ztree->configure('-fontcolorn' => 'cyan'); 
                       $ztree->configure('-bg' => 'black');
           });

$mw->after(20000, sub{ 
                    $ztree->configure('-backimage' => $tux ); 
                   });

my $y = 10;

$mw->after(21000, sub{ 
                       $mw->repeat(100,sub{ 
                                 $ztree->configure('-imy' => $y ); 
                                     $y += 2 });
      });


MainLoop;

[download]
I'm not really a human, but I play one on earth. flash japh

Replies are listed 'Best First'.
Re: Tk-CanvasDirTree
by liverpole (Monsignor) on Mar 31, 2006 at 12:45 UTC
    Very nice, zentara++.

    It has both a clean appearance and a comfortable "feel" to it as well.  And the default image is hilarious!

    s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/
[reply]
Re: Tk-CanvasDirTree
by GrandFather (Saint) on Mar 31, 2006 at 20:51 UTC

    It took me a while to realise I could click on the triangles (not being a Mac user). When I did "nothing happened". Actually I'd clicked on a large folder and it took a long time (1-2 seconds) to do stuff. I'd suggest using a busy cursor while folders are being parsed.

    A faded version of the background image would work better. Dark images make the text very hard to read. I know the image is user supplied, but having the module do the fading makes it easier for the user to plug in "just any ol' image".

    I haven't tried it nor looked at the code yet, but Windows' \\machine\drive\folders method of specifying network paths will break if the path is changed to //machine/drive/folders.

    However, nice work. :)

    DWIM is Perl's answer to Gödel
[reply]
      Yeah, the hour-glass is a good idea. I have a fairly fast machine with a good amount of ram, but I can imagine it can be slow on some older machines.

      I'm still working on the image portion. Tk dosn't support image operations very well, and there is no transparency. I'm hoping to make a Zinc version too, and Zinc supports zooming and transparency. Do you know of any image modules that will do a percentage fade?

      I'm not really a human, but I play one on earth. flash japh
[reply]

        Image Magick does a pretty fair job once you figure out how to do stuff. The documentation is less than stella.

        When you install make sure you check the option to hook up Perl. From memory it doesn't jump out and hit you in the eye!

        DWIM is Perl's answer to Gödel
[reply]
Re: Tk-CanvasDirTree
by zentara (Cardinal) on Apr 05, 2006 at 11:45 UTC
    Hi, in case any of you were interested in this, I made an update so that you can configure all it's options while running, using the normal ConfigSpecs mechanism of Tk. I've included the ability to move(change) the image. This is the last update to this package before I make it a cpan module. If any of you are test freaks, please see if and how it breaks anywhere. I did notice the reset rotation sometimes(rarely) being off by 90 degrees, but I think I fixed it with a call to idletasks where needed. But I only have 1 machine to test on, and I know that quite often that it is not enough to cover the wide possibilites of machine speeds out there. Thanks for reading.

    My ToDo list includes: the ability to blink individual indicators , trying to setup a scrollbar linked to the image, so that the image scrolls with the scrollbar, giving the appearance of a stationary image and scrolling text.

    I'm not really a human, but I play one on earth. flash japh
[reply]

Back to Cool Uses for Perl