← Back to branch summary

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

« back to all changes in this revision

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