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