home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / DirTree.pm < prev    next >
Encoding:
Perl POD Document  |  2003-12-14  |  6.0 KB  |  250 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 = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/;
  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 (CORE::chdir($path))
  54.   {
  55.    $path = getcwd();
  56.    CORE::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. {
  67.     my ($w,$key,$val) = @_;
  68.     # We need a value for -image, so its being undefined
  69.     # is probably caused by order of handling config defaults
  70.     # so defer it.
  71.     $w->afterIdle([$w, 'set_dir' => $val]);
  72. }
  73.  
  74. sub set_dir {
  75.     my( $w, $val ) = @_;
  76.     my $fulldir = fullpath( $val );
  77.  
  78.     my $parent = '/';
  79.     if ($^O eq 'MSWin32')
  80.      {
  81.       if ($fulldir =~ s/^([a-z]:)//i)
  82.        {
  83.         $parent = $1;
  84.        }
  85.      }
  86.     $w->add_to_tree( $parent, $parent)  unless $w->infoExists($parent);
  87.  
  88.     my @dirs = ($parent);
  89.     foreach my $name (split( /[\/\\]/, $fulldir )) {
  90.         next unless length $name;
  91.         push @dirs, $name;
  92.         my $dir = join( '/', @dirs );
  93.     $dir =~ s|^//|/|;
  94.         $w->add_to_tree( $dir, $name, $parent )
  95.             unless $w->infoExists( $dir );
  96.         $parent = $dir;
  97.     }
  98.  
  99.     $w->OpenCmd( $parent );
  100.     $w->setmode( $parent, 'close' );
  101. }
  102. *chdir = \&set_dir;
  103.  
  104.  
  105. sub OpenCmd {
  106.     my( $w, $dir ) = @_;
  107.  
  108.     my $parent = $dir;
  109.     $dir = '' if $dir eq '/';
  110.     foreach my $name ($w->dirnames( $parent )) {
  111.         next if ($name eq '.' || $name eq '..');
  112.         my $subdir = "$dir/$name";
  113.         next unless -d $subdir;
  114.         if( $w->infoExists( $subdir ) ) {
  115.             $w->show( -entry => $subdir );
  116.         } else {
  117.             $w->add_to_tree( $subdir, $name, $parent );
  118.         }
  119.     }
  120. }
  121.  
  122. *opencmd = \&OpenCmd;
  123.  
  124. sub add_to_tree {
  125.     my( $w, $dir, $name, $parent ) = @_;
  126.  
  127.     my $image = $w->Getimage( $w->cget('-image') );
  128.     my $mode = 'none';
  129.     $mode = 'open' if $w->has_subdir( $dir );
  130.  
  131.     my @args = (-image => $image, -text => $name);
  132.     if( $parent ) {             # Add in alphabetical order.
  133.         foreach my $sib ($w->infoChildren( $parent )) {
  134.             if( $sib gt $dir ) {
  135.                 push @args, (-before => $sib);
  136.                 last;
  137.             }
  138.         }
  139.     }
  140.  
  141.     $w->add( $dir, @args );
  142.     $w->setmode( $dir, $mode );
  143. }
  144.  
  145. sub has_subdir {
  146.     my( $w, $dir ) = @_;
  147.     foreach my $name ($w->dirnames( $dir )) {
  148.         next if ($name eq '.' || $name eq '..');
  149.         next if ($name =~ /^\.+$/);
  150.         return( 1 ) if -d "$dir/$name";
  151.     }
  152.     return( 0 );
  153. }
  154.  
  155. sub dirnames {
  156.     my( $w, $dir ) = @_;
  157.     my @names = $w->Callback( '-dircmd', $dir, $w->cget( '-showhidden' ) );
  158.     return( @names );
  159. }
  160.  
  161. {
  162.     package Tk::DirTreeDialog;
  163.     use base qw(Tk::Toplevel);
  164.     Construct Tk::Widget 'DirTreeDialog';
  165.  
  166.     sub Populate {
  167.     my($w, $args) = @_;
  168.     $w->{curr_dir} = $args->{-initialdir};
  169.     if (!defined $w->{curr_dir}) {
  170.         require Cwd;
  171.         $w->{curr_dir} = Cwd::cwd();
  172.     }
  173.     if (defined $args->{-mustexist}) {
  174.         die "-mustexist is not yet implemented";
  175.     }
  176.     my $title = $args->{-title} || "Choose directory:";
  177.     delete $args->{-popover};
  178.  
  179.     $w->title($title);
  180.     $w->{ok} = 0; # flag: "1" means OK, "-1" means cancelled
  181.  
  182.     # Create Frame widget before the DirTree widget, so it's always visible
  183.     # if the window gets resized.
  184.     my $f = $w->Frame->pack(-fill => "x", -side => "bottom");
  185.  
  186.     my $d;
  187.     $d = $f->Scrolled('DirTree',
  188.               -scrollbars => 'osoe',
  189.               -width => 35,
  190.               -height => 20,
  191.               -selectmode => 'browse',
  192.               -exportselection => 1,
  193.               -browsecmd => sub {
  194.                   $w->{curr_dir} = shift;
  195.                   if ($^O ne 'MSWin32') {
  196.                   $w->{curr_dir} =~ s|^//|/|; # bugfix
  197.                   }
  198.               },
  199.  
  200.               # With this version of -command a double-click will
  201.               # select the directory
  202.               -command   => sub { $w->{ok} = 1 },
  203.  
  204.               # With this version of -command a double-click will
  205.               # open a directory. Selection is only possible with
  206.               # the Ok button.
  207.               #-command   => sub { $d->opencmd($_[0]) },
  208.              )->pack(-fill => "both", -expand => 1);
  209.     # Set the initial directory
  210.     exists &Tk::DirTree::chdir ? $d->chdir($w->{curr_dir}) : $d->set_dir($w->{curr_dir});
  211.  
  212.     $f->Button(-text => 'Ok',
  213.            -command => sub { $w->{ok} =  1 })->pack(-side => 'left');
  214.     $f->Button(-text => 'Cancel',
  215.            -command => sub { $w->{ok} = -1 })->pack(-side => 'left');
  216.     $w->OnDestroy(sub { $w->{ok} = -1 });
  217.     }
  218.  
  219.     sub Show {
  220.     my $w = shift;
  221.     my $old_focus = $w->focusSave;
  222.     my $old_grab = $w->grabSave;
  223.     Tk::catch {
  224.         $w->grab;
  225.     };
  226.     $w->waitVariable(\$w->{ok});
  227.     my $ret = $w->{ok} == 1 ? $w->{curr_dir} : undef;
  228.     $w->grabRelease if Tk::Exists($w);
  229.     &$old_focus;
  230.     &$old_grab;
  231.     $w->destroy if Tk::Exists($w);
  232.     $ret;
  233.     }
  234. }
  235.  
  236. 1;
  237.  
  238. __END__
  239.  
  240. #  Copyright (c) 1996, Expert Interface Technologies
  241. #  See the file "license.terms" for information on usage and redistribution
  242. #  of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  243. #
  244. #  The file man.macros and some of the macros used by this file are
  245. #  copyrighted: (c) 1990 The Regents of the University of California.
  246. #               (c) 1994-1995 Sun Microsystems, Inc.
  247. #  The license terms of the Tcl/Tk distrobution are in the file
  248. #  license.tcl.
  249.  
  250.