← Back to branch summary

~ubuntu-branches/ubuntu/utopic/libtk-dirselect-perl/utopic

« back to all changes in this revision

Viewing changes to lib/Tk/DirSelect.pm

  • Committer: Bazaar Package Importer
  • Author(s): Dominique Dumont, Nathan Handler, Salvatore Bonaccorso, Dominique Dumont, gregor herrmann
  • Date: 2010-02-27 20:53:47 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20100227205347-5ok1xlvusp7s68yz
Tags: 1.12-1
[ Nathan Handler ]
* debian/watch: Update to ignore development releases.

[ Salvatore Bonaccorso ]
* debian/control: Changed: Replace versioned (build-)dependency on
  perl (>= 5.6.0-{12,16}) with an unversioned dependency on perl (as
  permitted by Debian Policy 3.8.3).

[ Dominique Dumont ]
* New upstream release
* debian/copyright: updated years and upstream license
* debian/control: updated to standard version 3.8.4

[ gregor herrmann ]
* Minimize debian/rules.
* debian/control: remove version from perl-tk (build) dependency, fulfilled
  since at least oldstable; add libtest-pod-perl to Build-Depends-Indep; add
  libtest-pod-coverage-perl to Build-Conflicts-Indep.
* debian/copyright: update formatting.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/Tk/DirSelect.pm
 
1
#===============================================================================
 
2
# Tk/DirSelect.pm
 
3
# Copyright (C) 2000-2001 Kristi Thompson <kristi@kristi.ca>
 
4
# Copyright (C) 2002-2005,2010 Michael Carman <mjcarman@mchsi.com>
 
5
# Last Modified: 2/16/2010
 
6
#===============================================================================
 
7
BEGIN { require 5.004 }
 
8
 
 
9
package Tk::DirSelect;
 
10
use Cwd;
 
11
use File::Spec;
 
12
use Tk 800;
 
13
require Tk::Frame;
 
14
require Tk::BrowseEntry;
 
15
require Tk::Button;
 
16
require Tk::Label;
 
17
require Tk::DirTree;
 
18
 
 
19
use strict;
 
20
use base 'Tk::Toplevel';
 
21
Construct Tk::Widget 'DirSelect';
 
22
 
 
23
use vars qw'$VERSION';
 
24
$VERSION = '1.12';
 
25
 
 
26
my %colors;
 
27
my $isWin32;
 
28
 
 
29
#-------------------------------------------------------------------------------
 
30
# Subroutine : ClassInit()
 
31
# Purpose    : Class initialzation.
 
32
# Notes      : 
 
33
#-------------------------------------------------------------------------------
 
34
sub ClassInit {
 
35
        my ($class, $mw) = @_;
 
36
        $class->SUPER::ClassInit($mw);
 
37
 
 
38
        $isWin32 = $^O eq 'MSWin32';
 
39
 
 
40
        # Get system colors from a Text widget for use in DirTree
 
41
        my $t = $mw->Text();
 
42
        foreach my $x (qw'-background -selectbackground -selectforeground') {
 
43
                $colors{$x} = $t->cget($x);
 
44
        }
 
45
        $t->destroy();
 
46
}
 
47
 
 
48
 
 
49
#-------------------------------------------------------------------------------
 
50
# Subroutine : Populate()
 
51
# Purpose    : Create the DirSelect widget
 
52
# Notes      : 
 
53
#-------------------------------------------------------------------------------
 
54
sub Populate {
 
55
        my ($w, $args) = @_;
 
56
        my $directory  = delete $args->{-dir}   || cwd();
 
57
        my $title      = delete $args->{-title} || 'Select Directory';
 
58
 
 
59
    $w->withdraw;
 
60
        $w->SUPER::Populate($args);
 
61
        $w->ConfigSpecs(-title => ['METHOD', 'title', 'Title', $title]);
 
62
        $w->bind('<Escape>', sub { $w->{dir} = undef });
 
63
 
 
64
        my %f = (
 
65
                drive  => $w->Frame->pack(-anchor => 'n', -fill => 'x'),
 
66
                button => $w->Frame->pack(-side => 'bottom', -anchor => 's', -fill => 'x', -ipady  => 6),
 
67
                tree   => $w->Frame->pack(-fill => 'both', -expand => 1),
 
68
        );
 
69
 
 
70
        $w->{tree} = $f{tree}->Scrolled('DirTree',
 
71
                -scrollbars       => 'osoe',
 
72
                -selectmode       => 'single',
 
73
                -ignoreinvoke     => 0,
 
74
                -width            => 50,
 
75
                -height           => 15,
 
76
                %colors,
 
77
                %$args,
 
78
        )->pack(-fill => 'both', -expand => 1);
 
79
 
 
80
        $w->{tree}->configure(-command   => sub { $w->{tree}->opencmd($_[0]) });
 
81
        $w->{tree}->configure(-browsecmd => sub { $w->{tree}->anchorClear });
 
82
 
 
83
        $f{button}->Button(
 
84
                -width   => 7,
 
85
                -text    => 'OK',
 
86
                -command => sub { $w->{dir} = $w->{tree}->selectionGet() },
 
87
        )->pack(-side => 'left', -expand => 1);
 
88
 
 
89
        $f{button}->Button(
 
90
                -width   => 7,
 
91
                -text    => 'Cancel',
 
92
                -command => sub { $w->{dir} = undef },
 
93
        )->pack(-side => 'left', -expand => 1);
 
94
 
 
95
        if ($isWin32) {
 
96
                $f{drive}->Label(-text => 'Drive:')->pack(-side => 'left');
 
97
                $w->{drive} = $f{drive}->BrowseEntry(
 
98
                        -variable  => \$w->{selected_drive},
 
99
                        -browsecmd => [\&_browse, $w->{tree}],
 
100
                        -state     => 'readonly',
 
101
                )->pack(-side => 'left', -fill => 'x', -expand => 1);
 
102
 
 
103
                if ($Tk::VERSION >= 804) {
 
104
                        # widget is readonly, but shouldn't appear disabled
 
105
                        for my $e ($w->{drive}->Subwidget('entry')->Subwidget('entry')) {
 
106
                                $e->configure(-disabledforeground => $colors{-foreground});
 
107
                                $e->configure(-disabledbackground => $colors{-background});
 
108
                        }
 
109
                }
 
110
        }
 
111
        else {
 
112
                $f{drive}->destroy;
 
113
        }
 
114
 
 
115
        # right-click context menu
 
116
        my $menu = $w->Menu(
 
117
                -tearoff   => 0,
 
118
                -menuitems => [
 
119
                        [qw/command ~New/,    -command => [\&_mkdir , $w]],
 
120
                        [qw/command ~Rename/, -command => [\&_rename, $w]],
 
121
                        [qw/command ~Delete/, -command => [\&_rmdir,  $w]],
 
122
                ],
 
123
        );
 
124
        $menu->bind('<FocusOut>' => sub {$menu->unpost});
 
125
        $w->{tree}->bind('<Button-3>' => [\&_context, $menu, Ev('X'), Ev('Y')]);
 
126
 
 
127
        # popup overlay for renaming directories
 
128
        $w->{renameval} = undef;
 
129
        $w->{popup}     = $w->Toplevel();
 
130
        $w->{rename}    = $w->{popup}->Entry(
 
131
                -relief       => 'groove',
 
132
                -borderwidth  => 1,
 
133
        )->pack(-fill => 'x', -expand => 1);
 
134
        $w->{popup}->overrideredirect(1);
 
135
        $w->{popup}->withdraw;
 
136
        $w->{rename}->bind('<Escape>',          sub {$w->{renameval} = undef});
 
137
        $w->{rename}->bind('<FocusOut>',        sub {$w->{renameval} = undef});
 
138
        $w->{rename}->bind('<KeyPress-Return>', sub {$w->{renameval} = $w->{rename}->get});
 
139
 
 
140
        return $w;
 
141
}
 
142
 
 
143
 
 
144
#-------------------------------------------------------------------------------
 
145
# Subroutine : Show()
 
146
# Purpose    : Display the DirSelect widget.
 
147
# Notes      : 
 
148
#-------------------------------------------------------------------------------
 
149
sub Show {
 
150
        my $w     = shift;
 
151
        my $dir   = shift;
 
152
        my $cwd   = cwd();
 
153
        my $focus = $w->focusSave;
 
154
        my $grab  = $w->grabSave;
 
155
 
 
156
        $dir = $cwd unless defined $dir && -d $dir;
 
157
        chdir($dir);
 
158
 
 
159
        if ($isWin32) {
 
160
                # populate the drive list
 
161
                my @drives = _get_volume_info();
 
162
                $w->{drive}->delete(0, 'end');
 
163
                my $startdrive = _drive($dir);
 
164
 
 
165
                foreach my $d (@drives) {
 
166
                        $w->{drive}->insert('end', $d);
 
167
                        if ($startdrive eq _drive($d)) {
 
168
                                $w->{selected_drive} = $d;
 
169
                        }
 
170
                }
 
171
        }
 
172
 
 
173
        # show initial directory
 
174
        _showdir($w->{tree}, $dir);
 
175
 
 
176
        $w->Popup(@_);                # show widget
 
177
        $w->focus;                    # seize focus
 
178
        $w->grab;                     # seize grab
 
179
        $w->waitVariable(\$w->{dir}); # wait for user selection (or cancel)
 
180
        $w->grabRelease;              # release grab
 
181
        $w->withdraw;                 # run and hide
 
182
        $focus->();                   # restore prior focus
 
183
        $grab->();                    # restore prior grab
 
184
        chdir($cwd)                   # restore working directory
 
185
                or warn "Could not chdir() back to '$cwd' [$!]\n";
 
186
 
 
187
        # HList SelectionGet() behavior changed around Tk 804.025
 
188
        if (ref $w->{dir} eq 'ARRAY') {
 
189
                $w->{dir} = $w->{dir}[0];
 
190
        }
 
191
 
 
192
        {
 
193
                local $^W;
 
194
                $w->{dir} .= '/' if ($isWin32 && $w->{dir} =~ /:$/);
 
195
        }
 
196
 
 
197
        return $w->{dir};
 
198
}
 
199
 
 
200
 
 
201
#-------------------------------------------------------------------------------
 
202
# Subroutine : _browse()
 
203
# Purpose    : Browse to a mounted filesystem (Win32)
 
204
# Notes      : 
 
205
#-------------------------------------------------------------------------------
 
206
sub _browse {
 
207
        my ($w, undef, $d) = @_;
 
208
        $d = _drive($d) . '/';
 
209
        chdir($d);
 
210
        _showdir($w, $d);
 
211
 
 
212
        # Workaround: Under Win* versions of Perl/Tk, scrollbars have a tendancy
 
213
        # to show up but be disabled.
 
214
        $w->yview(scroll => 1, 'units');
 
215
        $w->update;
 
216
        $w->yview(scroll => -1, 'units');
 
217
}
 
218
 
 
219
 
 
220
#-------------------------------------------------------------------------------
 
221
# Subroutine : _showdir()
 
222
# Purpose    : Show the requested directory
 
223
# Notes      : 
 
224
#-------------------------------------------------------------------------------
 
225
sub _showdir {
 
226
        my $w   = shift;
 
227
        my $dir = shift;
 
228
        $w->delete('all');
 
229
        $w->chdir($dir);
 
230
}
 
231
 
 
232
 
 
233
#-------------------------------------------------------------------------------
 
234
# Subroutine : _get_volume_info()
 
235
# Purpose    : Get volume information (Win32)
 
236
# Notes      : 
 
237
#-------------------------------------------------------------------------------
 
238
sub _get_volume_info {
 
239
        require Win32API::File;
 
240
 
 
241
        my @drivetype = (
 
242
                'Unknown',
 
243
                'No root directory',
 
244
                'Removable disk drive',
 
245
                'Fixed disk drive',
 
246
                'Network drive',
 
247
                'CD-ROM drive',
 
248
                'RAM Disk',
 
249
        );
 
250
 
 
251
        my @drives;
 
252
        foreach my $ld (Win32API::File::getLogicalDrives()) {
 
253
                my $drive = _drive($ld);
 
254
                my $type  = $drivetype[Win32API::File::GetDriveType($drive)];
 
255
                my $label;
 
256
 
 
257
                Win32API::File::GetVolumeInformation(
 
258
                        $drive, $label, [], [], [], [], [], []);
 
259
 
 
260
                push @drives, "$drive  [$label] $type";
 
261
        }
 
262
 
 
263
        return @drives;
 
264
}
 
265
 
 
266
 
 
267
#-------------------------------------------------------------------------------
 
268
# Subroutine : _drive()
 
269
# Purpose    : Get the drive letter (Win32)
 
270
# Notes      : 
 
271
#-------------------------------------------------------------------------------
 
272
sub _drive {
 
273
        shift =~ /^(\w:)/;
 
274
        return uc $1;
 
275
}
 
276
 
 
277
 
 
278
#-------------------------------------------------------------------------------
 
279
# Method  : _context
 
280
# Purpose : Display the context menu
 
281
# Notes   : 
 
282
#-------------------------------------------------------------------------------
 
283
sub _context {
 
284
        my ($w, $m, $x, $y) = @_;
 
285
        my $wy = $y - $w->rooty;
 
286
        $w->selectionClear();
 
287
        $w->selectionSet($w->nearest($wy));
 
288
        $m->post($x, $y);
 
289
        $m->focus;
 
290
}
 
291
 
 
292
 
 
293
#-------------------------------------------------------------------------------
 
294
# Method  : _mkdir
 
295
# Purpose : Create a new directory under the current selection
 
296
# Notes   : 
 
297
#-------------------------------------------------------------------------------
 
298
sub _mkdir  {
 
299
        my $w     = shift;
 
300
        my $dt    = $w->{tree};
 
301
        my ($sel) = $dt->selectionGet();
 
302
 
 
303
        my $cwd  = Cwd::cwd();
 
304
        if (chdir($sel)) {
 
305
                my $base = 'NewDirectory';
 
306
                my $name = $base;
 
307
                my $i    = 1;
 
308
 
 
309
                while (-d $name && $i < 1000) {
 
310
                        $name = $base . $i++;
 
311
                }
 
312
 
 
313
                unless (-d $name) {
 
314
                        if (mkdir($name)) {
 
315
                                _showdir($dt, $sel);
 
316
                                $dt->selectionClear();
 
317
                                $dt->selectionSet($sel . '/' . $name);
 
318
                                $w->_rename();
 
319
                        }
 
320
                        else {
 
321
                                $w->messageBox(
 
322
                                        -title   => 'Unable to create directory',
 
323
                                        -message => "The directory '$name' could not be created.\n$!",
 
324
                                        -icon    => 'error',
 
325
                                        -type    => 'OK',
 
326
                                );
 
327
                        }
 
328
                }
 
329
 
 
330
                chdir($cwd);
 
331
        }
 
332
        else {
 
333
                warn "Unable to chdir() for mkdir() [$!]\n";
 
334
        }
 
335
}
 
336
 
 
337
 
 
338
#-------------------------------------------------------------------------------
 
339
# Method  : _rmdir
 
340
# Purpose : Delete the selected directory
 
341
# Notes   : 
 
342
#-------------------------------------------------------------------------------
 
343
sub _rmdir {
 
344
        my $w     = shift;
 
345
        my $dt    = $w->{tree};
 
346
        my ($sel) = $dt->selectionGet();
 
347
 
 
348
        my @path = File::Spec->splitdir($sel);
 
349
        my $dir  = pop @path;
 
350
        my $pdir = File::Spec->catdir(@path);
 
351
 
 
352
        my $cwd  = Cwd::cwd();
 
353
        if (chdir($pdir)) {
 
354
                if (rmdir($dir)) {
 
355
                        _showdir($dt, $pdir);
 
356
                }
 
357
                else {
 
358
                        $w->messageBox(
 
359
                                -title   => 'Unable to delete directory',
 
360
                                -message => "The directory '$dir' could not be deleted.\n$!",
 
361
                                -icon    => 'error',
 
362
                                -type    => 'OK',
 
363
                        );
 
364
                }
 
365
                chdir($cwd);
 
366
        }
 
367
        else {
 
368
                warn "Unable to chdir() for rmdir() [$!]\n";
 
369
        }
 
370
}
 
371
 
 
372
#-------------------------------------------------------------------------------
 
373
# Method  : _rename
 
374
# Purpose : Rename the selected directory
 
375
# Notes   : 
 
376
#-------------------------------------------------------------------------------
 
377
sub _rename {
 
378
        my $w       = shift;
 
379
        my $dt      = $w->{tree};
 
380
        my $popup   = $w->{popup};
 
381
        my $entry   = $w->{rename};
 
382
        my ($sel)   = $dt->selectionGet();
 
383
        my ($x, $y, $x1, $y1) = $dt->infoBbox($sel);
 
384
 
 
385
        my @path = File::Spec->splitdir($sel);
 
386
        my $dir  = pop @path;
 
387
        my $pdir = File::Spec->catdir(@path);
 
388
 
 
389
        $entry->delete(0, 'end');
 
390
        $entry->insert(0, $dir);
 
391
        $entry->selectionRange(0, 'end');
 
392
        $entry->focus;
 
393
 
 
394
        my $font  = ($entry->configure(-font))[4];
 
395
        my $text  = 'ABCDEFGHIGKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789 ';
 
396
        my $width = $entry->fontMeasure($font, $text) / length($text);
 
397
        $entry->configure(-width => ($x1 - $x) / $width);
 
398
 
 
399
        $popup->Post($dt->rootx + $x, $dt->rooty + $y);
 
400
        $popup->waitVariable(\$w->{renameval});
 
401
        $popup->withdraw;
 
402
 
 
403
        if (defined $w->{renameval} && $w->{renameval} ne $dir) {
 
404
                my $cwd  = Cwd::cwd();
 
405
 
 
406
                if (chdir($pdir)) {
 
407
                        unless (rename($dir, $w->{renameval})) {
 
408
                                $w->messageBox(
 
409
                                        -title   => 'Unable to rename directory',
 
410
                                        -message => "The directory '$dir' could not be renamed.\n$!",
 
411
                                        -icon    => 'error',
 
412
                                        -type    => 'OK',
 
413
                                );
 
414
                        }
 
415
                        chdir($cwd);
 
416
                        _showdir($dt, $pdir); # rebrowse to update the display
 
417
                }
 
418
                else {
 
419
                        warn "Unable to chdir() for rename() [$!]\n";
 
420
                }
 
421
        }
 
422
}
 
423
 
 
424
 
 
425
1;
 
426
 
 
427
__END__
 
428
=pod
 
429
 
 
430
=head1 NAME
 
431
 
 
432
Tk::DirSelect - Cross-platform directory selection widget.
 
433
 
 
434
=head1 SYNOPSIS
 
435
 
 
436
  use Tk::DirSelect;
 
437
  my $ds  = $mw->DirSelect();
 
438
  my $dir = $ds->Show();
 
439
 
 
440
=head1 DESCRIPTION
 
441
 
 
442
This module provides a cross-platform directory selection widget. For 
 
443
systems running Microsoft Windows, this includes selection of local and 
 
444
mapped network drives. A context menu (right-click or E<lt>Button3E<gt>) 
 
445
allows the creation, renaming, and deletion of directories while 
 
446
browsing.
 
447
 
 
448
Note: Perl/Tk 804 added the C<chooseDirectory> method which uses native 
 
449
system dialogs where available. (i.e. Windows) If you want a native feel 
 
450
for your program, you probably want to use that method instead --
 
451
possibly using this module as a fallback for systems with older versions 
 
452
of Tk installed.
 
453
 
 
454
=head1 METHODS
 
455
 
 
456
=head2 C<DirSelect([-title =E<gt> 'title'], [options])>
 
457
 
 
458
Constructs a new DirSelect widget as a child of the invoking object 
 
459
(usually a MainWindow). 
 
460
 
 
461
The title for the widget can be set by specifying C<-title =E<gt> 
 
462
'Title'>. Any other options provided will be passed through to the 
 
463
DirTree widget that displays directories, so be sure they're appropriate 
 
464
(e.g. C<-width>)
 
465
 
 
466
=head2 C<Show([directory], [options])>
 
467
 
 
468
Displays the DirSelect widget and returns the user selected directory or 
 
469
C<undef> if the operation is canceled.
 
470
 
 
471
All arguments are optional. The first argument (if defined) is the 
 
472
initial directory to display. The default is to display the current 
 
473
working directory. Any additional options are passed through to the 
 
474
Popup() method. This means that you can do something like
 
475
 
 
476
  $ds->Show(undef, -popover => $mw);
 
477
 
 
478
to center the dialog over your application.
 
479
 
 
480
=head1 DEPENDENCIES
 
481
 
 
482
=over 4
 
483
 
 
484
=item * Perl 5.004
 
485
 
 
486
=item * Tk 800
 
487
 
 
488
=item * Win32API::File (under Microsoft Windows only)
 
489
 
 
490
=back
 
491
 
 
492
=head1 LICENSE AND COPYRIGHT
 
493
 
 
494
Copyright 2000-2001 Kristi Thompson <kristi@kristi.ca>
 
495
Copyright 2002-2005,2010 Michael Carman <mjcarman@cpan.org>
 
496
 
 
497
This program is free software; you can redistribute it and/or modify it
 
498
under the terms of either: the GNU General Public License as published
 
499
by the Free Software Foundation; or the Artistic License.
 
500
 
 
501
See http://dev.perl.org/licenses/ for more information.
 
502
 
 
503
=cut