home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _0142b9b2b58d24e2e4da05803a93eb6a < prev    next >
Text File  |  2004-06-01  |  7KB  |  253 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: #14 $ =~ /\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.     $dir .= "/" if $dir =~ /^[a-z]:$/i and $^O eq 'MSWin32';
  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->cget('-image');
  128.     if ( !UNIVERSAL::isa($image, 'Tk::Image') ) {
  129.     $image = $w->Getimage( $image );
  130.     }
  131.     my $mode = 'none';
  132.     $mode = 'open' if $w->has_subdir( $dir );
  133.  
  134.     my @args = (-image => $image, -text => $name);
  135.     if( $parent ) {             # Add in alphabetical order.
  136.         foreach my $sib ($w->infoChildren( $parent )) {
  137.             if( $sib gt $dir ) {
  138.                 push @args, (-before => $sib);
  139.                 last;
  140.             }
  141.         }
  142.     }
  143.  
  144.     $w->add( $dir, @args );
  145.     $w->setmode( $dir, $mode );
  146. }
  147.  
  148. sub has_subdir {
  149.     my( $w, $dir ) = @_;
  150.     foreach my $name ($w->dirnames( $dir )) {
  151.         next if ($name eq '.' || $name eq '..');
  152.         next if ($name =~ /^\.+$/);
  153.         return( 1 ) if -d "$dir/$name";
  154.     }
  155.     return( 0 );
  156. }
  157.  
  158. sub dirnames {
  159.     my( $w, $dir ) = @_;
  160.     my @names = $w->Callback( '-dircmd', $dir, $w->cget( '-showhidden' ) );
  161.     return( @names );
  162. }
  163.  
  164. {
  165.     package Tk::DirTreeDialog;
  166.     use base qw(Tk::Toplevel);
  167.     Construct Tk::Widget 'DirTreeDialog';
  168.  
  169.     sub Populate {
  170.     my($w, $args) = @_;
  171.     $w->{curr_dir} = $args->{-initialdir};
  172.     if (!defined $w->{curr_dir}) {
  173.         require Cwd;
  174.         $w->{curr_dir} = Cwd::cwd();
  175.     }
  176.     if (defined $args->{-mustexist}) {
  177.         die "-mustexist is not yet implemented";
  178.     }
  179.     my $title = $args->{-title} || "Choose directory:";
  180.     delete $args->{-popover};
  181.  
  182.     $w->title($title);
  183.     $w->{ok} = 0; # flag: "1" means OK, "-1" means cancelled
  184.  
  185.     # Create Frame widget before the DirTree widget, so it's always visible
  186.     # if the window gets resized.
  187.     my $f = $w->Frame->pack(-fill => "x", -side => "bottom");
  188.  
  189.     my $d;
  190.     $d = $f->Scrolled('DirTree',
  191.               -scrollbars => 'osoe',
  192.               -width => 35,
  193.               -height => 20,
  194.               -selectmode => 'browse',
  195.               -exportselection => 1,
  196.               -browsecmd => sub {
  197.                   $w->{curr_dir} = shift;
  198.                   if ($^O ne 'MSWin32') {
  199.                   $w->{curr_dir} =~ s|^//|/|; # bugfix
  200.                   }
  201.               },
  202.  
  203.               # With this version of -command a double-click will
  204.               # select the directory
  205.               -command   => sub { $w->{ok} = 1 },
  206.  
  207.               # With this version of -command a double-click will
  208.               # open a directory. Selection is only possible with
  209.               # the Ok button.
  210.               #-command   => sub { $d->opencmd($_[0]) },
  211.              )->pack(-fill => "both", -expand => 1);
  212.     # Set the initial directory
  213.     exists &Tk::DirTree::chdir ? $d->chdir($w->{curr_dir}) : $d->set_dir($w->{curr_dir});
  214.  
  215.     $f->Button(-text => 'Ok',
  216.            -command => sub { $w->{ok} =  1 })->pack(-side => 'left');
  217.     $f->Button(-text => 'Cancel',
  218.            -command => sub { $w->{ok} = -1 })->pack(-side => 'left');
  219.     $w->OnDestroy(sub { $w->{ok} = -1 });
  220.     }
  221.  
  222.     sub Show {
  223.     my $w = shift;
  224.     my $old_focus = $w->focusSave;
  225.     my $old_grab = $w->grabSave;
  226.     Tk::catch {
  227.         $w->grab;
  228.     };
  229.     $w->waitVariable(\$w->{ok});
  230.     my $ret = $w->{ok} == 1 ? $w->{curr_dir} : undef;
  231.     $w->grabRelease if Tk::Exists($w);
  232.     &$old_focus;
  233.     &$old_grab;
  234.     $w->destroy if Tk::Exists($w);
  235.     $ret;
  236.     }
  237. }
  238.  
  239. 1;
  240.  
  241. __END__
  242.  
  243. #  Copyright (c) 1996, Expert Interface Technologies
  244. #  See the file "license.terms" for information on usage and redistribution
  245. #  of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  246. #
  247. #  The file man.macros and some of the macros used by this file are
  248. #  copyrighted: (c) 1990 The Regents of the University of California.
  249. #               (c) 1994-1995 Sun Microsystems, Inc.
  250. #  The license terms of the Tcl/Tk distrobution are in the file
  251. #  license.tcl.
  252.  
  253.