ViewVC Help
View File | Revision Log | Show Annotations | Root Listing
root/yamap/DirSelect.pm
Revision: 1.1.1.1 (vendor branch)
Committed: Thu Sep 7 15:35:21 2006 UTC (9 years, 7 months ago) by knirirr
Branch: MAIN, cehox
CVS Tags: start, HEAD
Changes since 1.1: +0 -0 lines
Log Message:
Imported sources

Line File contents
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