view release on metacpan or  search on metacpan

CanvasDirTree.pm  view on Meta::CPAN

package Tk::CanvasDirTree;

our $VERSION = '0.04';
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->{'imy'}
	             );  
		 };
       #---------------------------------------------
   }
  
$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','floatback') {
       my $xtra_arg = delete $args->{ "-$extra" };  #delete and read same time 
     if( defined $xtra_arg ) { $self->{$extra} = $xtra_arg }
   }
   #-----------------------------------------------------------------

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

    $self->ConfigSpecs(
     -indfilla => [ 'PASSIVE', undef, undef , undef],  # need to set defaults
     -indfilln => [ 'PASSIVE', undef, undef, undef],   # below for unknown
     -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],
     -floatback => [ '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';
     $self->{'floatback'} ||= 0;
       
#---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); 

   $self->after(1,sub{ $self->_set_bars() });

} # end Populate

#######################################################################
sub _set_bars {
   my $self = shift;
   my $y = $self->parent->Subwidget('yscrollbar');
   $self->{'real_can'} =  $self->parent->Subwidget('scrolled');
   $self->idletasks;
   $y->configure( -command => [\&yscrollcallback,$self] );

    #account for any padding 
    $self->xviewMoveto(0);

CanvasDirTree.pm  view on Meta::CPAN

                 my $selected = $ztree->get_selected();
                 if(length $selected){print "$selected\n"}
		 });


#configuring
 $ztree->configure('-indfilla' => 'red' );
 $ztree->configure('-indfilln' => 'orange'); 
 $ztree->configure('-fontcolora' => 'white');
 $ztree->configure('-fontcolorn' => 'cyan'); 
 $ztree->configure('-bg' => 'black');     # gif, jpg, or png file
 $ztree->configure('-backimage' => $tux ); 
 $ztree->configure('-imy' => 45 ); 
 $ztree->configure('-imx' => 25 ); 

 
 
=head1 DESCRIPTION

This widget reads a directory tree, in an efficient manner, and provides
an intuitive graphical interface to selecting them. It only recurses 2 levels
at a time, so it is efficient on deeply nested trees. 
It is similar in appearance to the Gtk2 TreeView. Colors and fonts are
configurable, as well as a background image (with configurable location placement).
Also with -floatback => 1, the background image will appear to stay stationary
as the y scrollbar is moved.
Due to the wide variety of possible color schemes, creating a pleasing 
background image is left to you. See the included scripts in the scripts
directory, for examples to make charcoal or faded backgrounds.

It is a single mouse click selector( I nevered liked double-click bindings :-) ).
If a sub-directory has subdirs in it's own tree, a colored triangular shaped
indicator will be placed to the left of the subdir. Clicking on the indicator
will expand that subdir tree, and subsequent clicks will close it.

The basic operation is simple. A left mouse click on a subdirectory, will
return it's full path. You can then do what you want with the path, from 
your main script.

This widget is a derived Tk::Canvas, can be treated like a Canvas. 
It contains additional configuration options:

    -backimage => 'bridget-5a.jpg',  # either a file 
    -backimage => $bunny,            # or Tk::Photo object data 
    -imx => 200,                     # image position relative to nw corner 
    -imy => 10,                      # to place nw corner of image 
    -floatback => 1,                 # floating background, defaults to 0
    -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 

=head2 EXPORT

None.

=head1 SEE ALSO

See "perldoc Tk::Canvas" for the standard Canvas options
See perldoc Tk::Derived for information on how this module was derived.


=head1 AUTHOR

zentara, E<lt>zentara@zentara.netE<gt>
See  http://zentara.net/perlplay  for other perl script examples.

=head1 COPYRIGHT AND LICENSE

Copyright (C)April 14, 2006 by Joseph B. Milosch a.k.a zentara

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.


=cut