home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _0142b9b2b58d24e2e4da05803a93eb6a < prev    next >
Encoding:
Text File  |  2004-04-13  |  4.2 KB  |  177 lines
  1. package Tk::DirTree;
  2. # DirTree -- TixDirTree widget
  3. #
  4. # Derived from DirTree.tcl in Tix 4.1
  5. #
  6. # Chris Dean <ctdean@cogit.com>
  7.  
  8. use vars qw($VERSION);
  9. $VERSION = '3.023'; # $Id: //depot/Tk8/Tixish/DirTree.pm#23 $
  10.  
  11. use Tk;
  12. use Tk::Derived;
  13. use Tk::Tree;
  14. use Cwd;
  15. use DirHandle;
  16.  
  17. use base  qw(Tk::Derived Tk::Tree);
  18. use strict;
  19.  
  20. Construct Tk::Widget 'DirTree';
  21.  
  22.  
  23. sub Populate {
  24.     my( $cw, $args ) = @_;
  25.  
  26.     $cw->SUPER::Populate( $args );
  27.  
  28.     $cw->ConfigSpecs(
  29.         -dircmd         => [qw/CALLBACK dirCmd DirCmd DirCmd/],
  30.         -showhidden     => [qw/PASSIVE showHidden ShowHidden 0/],
  31.         -image          => [qw/PASSIVE image Image folder/],
  32.         -directory      => [qw/SETMETHOD directory Directory ./],
  33.         -value          => '-directory' );
  34.  
  35.     $cw->configure( -separator => '/', -itemtype => 'imagetext' );
  36. }
  37.  
  38. sub DirCmd {
  39.     my( $w, $dir, $showhidden ) = @_;
  40.  
  41.     my $h = DirHandle->new( $dir ) or return();
  42.     my @names = grep( $_ ne '.' && $_ ne '..', $h->read );
  43.     @names = grep( ! /^[.]/, @names ) unless $showhidden;
  44.     return( @names );
  45. }
  46.  
  47. *dircmd = \&DirCmd;
  48.  
  49. sub fullpath
  50. {
  51.  my ($path) = @_;
  52.  my $cwd = getcwd();
  53.  if (chdir($path))
  54.   {
  55.    $path = getcwd();
  56.    chdir($cwd) || die "Cannot cd back to $cwd:$!";
  57.   }
  58.  else
  59.   {
  60.    warn "Cannot cd to $path:$!"
  61.   }
  62.  return $path;
  63. }
  64.  
  65. sub directory {
  66.     my ($w,$key,$val) = @_;
  67.     if (defined $w->cget('-image'))
  68.      {
  69.       $w->chdir( $val );
  70.      }
  71.     else
  72.      {
  73.       # We have a default for -image, so its being undefined
  74.       # is probably caused by order of handling config defaults
  75.       # so defer it.
  76.       $w->afterIdle([$w, 'chdir' => $val]);
  77.      }
  78. }
  79.  
  80. sub chdir {
  81.     my( $w, $val ) = @_;
  82.     my $fulldir = fullpath( $val );
  83.  
  84.     my $parent = '/';
  85.     if ($^O eq 'MSWin32')
  86.      {
  87.       if ($fulldir =~ s/^([a-z]:)//i)
  88.        {
  89.         $parent = $1;
  90.        }
  91.      }
  92.     $w->add_to_tree( $parent, $parent)  unless $w->infoExists($parent);
  93.  
  94.     my @dirs = ($parent);
  95.     foreach my $name (split( /[\/\\]/, $fulldir )) {
  96.         next unless length $name;
  97.         push @dirs, $name;
  98.         my $dir = join( '/', @dirs );
  99.         $w->add_to_tree( $dir, $name, $parent )
  100.             unless $w->infoExists( $dir );
  101.         $parent = $dir;
  102.     }
  103.  
  104.     $w->OpenCmd( $parent );
  105.     $w->setmode( $parent, 'close' );
  106. }
  107.  
  108.  
  109. sub OpenCmd {
  110.     my( $w, $dir ) = @_;
  111.  
  112.     my $parent = $dir;
  113.     $dir = '' if $dir eq '/';
  114.     foreach my $name ($w->dirnames( $parent )) {
  115.         next if ($name eq '.' || $name eq '..');
  116.         my $subdir = "$dir/$name";
  117.         next unless -d $subdir;
  118.         if( $w->infoExists( $subdir ) ) {
  119.             $w->show( -entry => $subdir );
  120.         } else {
  121.             $w->add_to_tree( $subdir, $name, $parent );
  122.         }
  123.     }
  124. }
  125.  
  126. *opencmd = \&OpenCmd;
  127.  
  128. sub add_to_tree {
  129.     my( $w, $dir, $name, $parent ) = @_;
  130.  
  131.     my $image = $w->Getimage( $w->cget('-image') );
  132.     my $mode = 'none';
  133.     $mode = 'open' if $w->has_subdir( $dir );
  134.  
  135.     my @args = (-image => $image, -text => $name);
  136.     if( $parent ) {             # Add in alphabetical order.
  137.         foreach my $sib ($w->infoChildren( $parent )) {
  138.             if( $sib gt $dir ) {
  139.                 push @args, (-before => $sib);
  140.                 last;
  141.             }
  142.         }
  143.     }
  144.  
  145.     $w->add( $dir, @args );
  146.     $w->setmode( $dir, $mode );
  147. }
  148.  
  149. sub has_subdir {
  150.     my( $w, $dir ) = @_;
  151.     foreach my $name ($w->dirnames( $dir )) {
  152.         next if ($name eq '.' || $name eq '..');
  153.         next if ($name =~ /^\.+$/);
  154.         return( 1 ) if -d "$dir/$name";
  155.     }
  156.     return( 0 );
  157. }
  158.  
  159. sub dirnames {
  160.     my( $w, $dir ) = @_;
  161.     my @names = $w->Callback( '-dircmd', $dir, $w->cget( '-showhidden' ) );
  162.     return( @names );
  163. }
  164.  
  165. __END__
  166.  
  167. #  Copyright (c) 1996, Expert Interface Technologies
  168. #  See the file "license.terms" for information on usage and redistribution
  169. #  of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  170. #
  171. #  The file man.macros and some of the macros used by this file are
  172. #  copyrighted: (c) 1990 The Regents of the University of California.
  173. #               (c) 1994-1995 Sun Microsystems, Inc.
  174. #  The license terms of the Tcl/Tk distrobution are in the file
  175. #  license.tcl.
  176.  
  177.