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 it's 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 it's 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
use warnings;
use strict;
use Tk;

##########################################################
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(@_);
}

######################################3
sub SetBindtags {
    my($self) = @_;
    $self->SUPER::SetBindtags;
}

######################################################
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 same time 
     if( defined $xtra_arg ) { $self->{$extra} = $xtra_arg }
   }
   #-----------------------------------------------------------------
    #set some defaults
    $self->{'indfilla'} ||= 'red';        
    $self->{'indfilln'} ||= 'pink'; 
    $self->{'fontcolorn'} ||= 'black';
    $self->{'fontcolora'} ||= 'red';
    $self->{'backimage'} ||= '';
    $self->{'bimage'} ||= '';
    $self->{'imx'} ||= 0;
    $self->{'imy'} ||= 0;
    

    $self->SUPER::Populate($args);   
    $self->SetBindtags;
    
   if( length $self->{'backimage'} > 0 ){
       $self->set_background( 
            $self->{'backimage'},$self->{'imx'}, $self->{'imy'}
	    );  
     }

  $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'},
    );
 }
############################################################
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 make_trunk{

   my ($self, $dir, $level) = @_;
   my $x = 5; my $y = $self->{'f_height'};

   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 }
     }

   my $abs_root = File::Spec->rel2abs( $dir );

    #for windows compat
    $abs_root =~ tr#\\#/#; 
   
    my $max = scalar (@subdirs);
    my $count = 0;
  
    foreach my $subdir ( sort @subdirs ){
           my $abs_path = "$abs_root/$subdir";
           my $put_ind = 0;

               #see if any depth 2 subdir exists
               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;        
  	             }
                 }

     #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 * $self->{'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 ){
       
        @tags =  grep { $_ ne 'ind' and  $_ ne 'current'} @tags;
        my $dir = $tags[0];

       if( $self->itemcget($item, 'fill') eq $self->{'indfilla'}){
               $self->rotate_poly($item, -90, undef,undef);
               $self->itemconfigure($item, 'fill' => $self->{'indfilln'} );
               $self->close_branch($dir,$item);
	}else{
	       $self->rotate_poly($item, 90, undef,undef);
               $self->itemconfigure($item, 'fill' => $self->{'indfilla'} );
    	       $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) = @_;

    #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; 
   opendir my $dh, $abs_path or warn $!;
     while ( my $file = readdir($dh) ) {
        next if $file =~ m[^\.{1,2}$];
         if(-d "$abs_path/$file"){ 
           push @subdirs, $file;       
  	 }else{ next }
     }
      
   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");
	    my $put_ind = 0;

           #see if any depth 2 subdir exists
           opendir my $dh, $abs_path1 or warn $!;
               while ( my $file = readdir($dh) ) {
                 next if $file =~ m[^\.{1,2}$];
                 if(-d "$abs_path1/$file"){ 
                     $put_ind = 1;
		     last;        
  	             }
                 }
     #for windows compat
     $abs_path1 =~ tr#\\#/#; 
 
      #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++;
   }


    ($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
    ($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_height'}); 
  
  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;

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 => 
'iVBORw0KGgoAAAANSUhEUgAAAB4AAAAjEAIAAABcJvHFAAAACXBIWXMAAAsSAAALEgHS3X78AAAD
F0lEQVR42u1YL+yqUBj1vfcLbhY3C44is8BIREYSG9FoNBqNkok2aFhp2BhJDWyadCZN/ilOGxan
jRdOuRsPxl/f+23vJKfX7x6+73znu5dK5RviV9QPDMMwDIPP7/f7/X6XTWU0Go1Go06n0+l0PM/z
PC91CNu2bduWZVmW5bLpjsfj8XgcBEEQBJPJZDKZZAw0n8/n8zkCGYZhGIYgCIIgFEt3OBwOh8OA
gKZpmqZlDDedTqfTKRnO933f95GVer1er9fz0BVFURRFxCR3QfyMQfv9fr/fDyLgOI7jONmo419k
JUkMBoPBYJCRNBrxdrvdbrco6qvVarVaIWdFpQO/5tIcFBbE4nQ6nU6nJIpHjlGlEklTFEVRFDIa
T32/3+/3+3jqHMdxHBcfB2sK6HFFURRFeb1er9crfksoNUrr0GvUfxGfnA+FmX+QALDItGLDA6O2
pQyCJFkPqxMDK2p9LodOAhQaLRjfoKRGo2wObl3G8PoDsA0Gb5Q5oonjfSNKTh96AOh+u91ut1uS
FuZrONPJ7bJ06tA9TDDsD6QkCnDltEDRkV1Q9AnENyuk8hcyChkkcZKo5uv1er1er3S6cAPkFXSx
MQodPrXFg2zTEsVANhO2JNdEmVo80ub7K/lSDHPyLkNaXrVarVar2W46LMuyLFsKaZ7neZ4nvwFR
NGKeGjYajUajkXz9z+RLn8/n8/ms/ANIQXq5XC6Xy/v9fr/fvw3p9Xq9Xq9VVVVV9fF4PB6Pokhc
r9fr9Vr6s6Lf4dNpbS6/exQA3BHDt/fkPl3wwT85wlcEcrCHZyHO1tmOSl95iGLcQN80TdM0jTa1
LMuyLF3XdV03TdM0zWaz2Ww2Xdd1XRenDlDHgTbtvj/ykMZpDm/6LpfL5XLBmGi32+12G6Th5RAA
Pne73W63iwfGYFosFovF4kOZrtVqtVoN16TD4XA4HPAAKDp5yZUkSZIk1GGz2Ww2m91ut9vt0Mof
lcfxeDwej7PZbDaboRFbrVar1SJfIsLdYZfn8/l8Pue3y1zyiH9VAMFElb5Yp/+PcvAbH/25ox5S
PYYAAAAASUVORK5CYII=');

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 => 170,     # position relative to nw corner
	    -imy => 10,     # to place nw corner of image
	    -font => 'big',
	    -fontcolorn => 'black',
	    -fontcolora => 'red',
	    -indfilln => 'blue',
	    -indfilla => '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('', sub{   
               my $selected = $ztree->get_selected();

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

MainLoop;