← Back to branch summary

~ubuntu-branches/ubuntu/lucid/perl-tk/lucid

« back to all changes in this revision

Viewing changes to Tixish/DirTree.pm

  • Committer: Bazaar Package Importer
  • Author(s): Colin Tuckley
  • Date: 2008-02-15 13:56:59 UTC
  • mfrom: (1.1.3 upstream) (4.1.1 hardy)
  • Revision ID: james.westby@ubuntu.com-20080215135659-ru2oqlykuju20fav
Tags: 1:804.028-1
http://bugs.debian.org/463080
http://bugs.debian.org/411129
* New Upstream Release (Closes: #463080).
* Update to Debhelper v5.
* Build with XFT=1 (Closes: #411129).

Show diffs side-by-side

added added

removed removed

Lines of Context:
Tixish/DirTree.pm
5
5
#
6
6
# Chris Dean <ctdean@cogit.com>
7
7
 
 
8
use strict;
8
9
use vars qw($VERSION);
9
 
$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
 
10
$VERSION = '4.019';
10
11
 
11
12
use Tk;
12
13
use Tk::Derived;
13
14
use Tk::Tree;
14
15
use Cwd;
15
16
use DirHandle;
 
17
use File::Spec qw();
16
18
 
17
19
use base  qw(Tk::Derived Tk::Tree);
18
20
use strict;
19
21
 
20
22
Construct Tk::Widget 'DirTree';
21
23
 
 
24
my $sep = $^O eq 'MSWin32' ? '\\' : '/';
 
25
 
 
26
*_fs_encode = eval { require Encode; 1 } ? sub { Encode::encode("iso-8859-1", $_[0]) } : sub { $_[0] };
22
27
 
23
28
sub Populate {
24
29
    my( $cw, $args ) = @_;
32
37
        -directory      => [qw/SETMETHOD directory Directory ./],
33
38
        -value          => '-directory' );
34
39
 
35
 
    $cw->configure( -separator => '/', -itemtype => 'imagetext' );
 
40
    $cw->configure( -separator => $sep,
 
41
                    -itemtype => 'imagetext',
 
42
                  );
36
43
}
37
44
 
38
45
sub DirCmd {
39
46
    my( $w, $dir, $showhidden ) = @_;
40
 
    $dir .= "/" if $dir =~ /^[a-z]:$/i and $^O eq 'MSWin32';
 
47
    $dir .= $sep if $dir =~ /^[a-z]:$/i and $^O eq 'MSWin32';
41
48
    my $h = DirHandle->new( $dir ) or return();
42
49
    my @names = grep( $_ ne '.' && $_ ne '..', $h->read );
43
50
    @names = grep( ! /^[.]/, @names ) unless $showhidden;
59
66
  {
60
67
   warn "Cannot cd to $path:$!"
61
68
  }
 
69
 $path = File::Spec->canonpath($path);
62
70
 return $path;
63
71
}
64
72
 
75
83
    my( $w, $val ) = @_;
76
84
    my $fulldir = fullpath( $val );
77
85
 
78
 
    my $parent = '/';
 
86
    my $parent = $sep;
79
87
    if ($^O eq 'MSWin32')
80
88
     {
81
89
      if ($fulldir =~ s/^([a-z]:)//i)
86
94
    $w->add_to_tree( $parent, $parent)  unless $w->infoExists($parent);
87
95
 
88
96
    my @dirs = ($parent);
89
 
    foreach my $name (split( /[\/\\]/, $fulldir )) {
 
97
    foreach my $name (split( /\Q$sep\E/, $fulldir )) {
90
98
        next unless length $name;
91
99
        push @dirs, $name;
92
 
        my $dir = join( '/', @dirs );
93
 
        $dir =~ s|^//|/|;
 
100
        my $dir = File::Spec->catfile( @dirs );
94
101
        $w->add_to_tree( $dir, $name, $parent )
95
102
            unless $w->infoExists( $dir );
96
103
        $parent = $dir;
106
113
    my( $w, $dir ) = @_;
107
114
 
108
115
    my $parent = $dir;
109
 
    $dir = '' if $dir eq '/';
110
116
    foreach my $name ($w->dirnames( $parent )) {
111
117
        next if ($name eq '.' || $name eq '..');
112
 
        my $subdir = "$dir/$name";
 
118
        my $subdir = File::Spec->catfile( $dir, $name );
 
119
        $subdir = _fs_encode($subdir);
113
120
        next unless -d $subdir;
114
121
        if( $w->infoExists( $subdir ) ) {
115
122
            $w->show( -entry => $subdir );
124
131
sub add_to_tree {
125
132
    my( $w, $dir, $name, $parent ) = @_;
126
133
 
 
134
    my $dir8 = _fs_encode($dir);
127
135
    my $image = $w->cget('-image');
128
136
    if ( !UNIVERSAL::isa($image, 'Tk::Image') ) {
129
137
        $image = $w->Getimage( $image );
134
142
    my @args = (-image => $image, -text => $name);
135
143
    if( $parent ) {             # Add in alphabetical order.
136
144
        foreach my $sib ($w->infoChildren( $parent )) {
137
 
            if( $sib gt $dir ) {
 
145
            use locale;
 
146
            my $sib8 = _fs_encode($sib);
 
147
            if ($sib8 gt $dir8) {
138
148
                push @args, (-before => $sib);
139
149
                last;
140
150
            }
150
160
    foreach my $name ($w->dirnames( $dir )) {
151
161
        next if ($name eq '.' || $name eq '..');
152
162
        next if ($name =~ /^\.+$/);
153
 
        return( 1 ) if -d "$dir/$name";
 
163
        return( 1 ) if -d File::Spec->catfile( $dir, $name );
154
164
    }
155
165
    return( 0 );
156
166
}
168
178
 
169
179
    sub Populate {
170
180
        my($w, $args) = @_;
171
 
        $w->{curr_dir} = $args->{-initialdir};
 
181
        $w->{curr_dir} = delete $args->{-initialdir};
172
182
        if (!defined $w->{curr_dir}) {
173
183
            require Cwd;
174
184
            $w->{curr_dir} = Cwd::cwd();
187
197
        my $f = $w->Frame->pack(-fill => "x", -side => "bottom");
188
198
 
189
199
        my $d;
190
 
        $d = $f->Scrolled('DirTree',
 
200
        $d = $w->Scrolled('DirTree',
191
201
                          -scrollbars => 'osoe',
192
202
                          -width => 35,
193
203
                          -height => 20,
195
205
                          -exportselection => 1,
196
206
                          -browsecmd => sub {
197
207
                              $w->{curr_dir} = shift;
198
 
                              if ($^O ne 'MSWin32') {
199
 
                                  $w->{curr_dir} =~ s|^//|/|; # bugfix
200
 
                              }
201
208
                          },
202
209
 
203
210
                          # With this version of -command a double-click will
210
217
                          #-command   => sub { $d->opencmd($_[0]) },
211
218
                         )->pack(-fill => "both", -expand => 1);
212
219
        # Set the initial directory
213
 
        exists &Tk::DirTree::chdir ? $d->chdir($w->{curr_dir}) : $d->set_dir($w->{curr_dir});
 
220
        $d->set_dir($w->{curr_dir});
214
221
 
215
222
        $f->Button(-text => 'Ok',
216
223
                   -command => sub { $w->{ok} =  1 })->pack(-side => 'left');