Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::FileSelect; |
2 | ||
3 | use vars qw($VERSION @EXPORT_OK); | |
4 | $VERSION = '3.047'; # $Id: //depot/Tk8/Tk/FileSelect.pm#47 $ | |
5 | @EXPORT_OK = qw(glob_to_re); | |
6 | ||
7 | use Tk qw(Ev); | |
8 | use strict; | |
9 | use Carp; | |
10 | use base qw(Tk::Toplevel); | |
11 | use Tk::widgets qw(LabEntry Button Frame Listbox Scrollbar); | |
12 | use File::Basename; | |
13 | ||
14 | Construct Tk::Widget 'FileSelect'; | |
15 | ||
16 | use vars qw(%error_text); | |
17 | %error_text = ( | |
18 | '-r' => 'is not readable by effective uid/gid', | |
19 | '-w' => 'is not writeable by effective uid/gid', | |
20 | '-x' => 'is not executable by effective uid/gid', | |
21 | '-R' => 'is not readable by real uid/gid', | |
22 | '-W' => 'is not writeable by real uid/gid', | |
23 | '-X' => 'is not executable by real uid/gid', | |
24 | '-o' => 'is not owned by effective uid/gid', | |
25 | '-O' => 'is not owned by real uid/gid', | |
26 | '-e' => 'does not exist', | |
27 | '-z' => 'is not of size zero', | |
28 | '-s' => 'does not exists or is of size zero', | |
29 | '-f' => 'is not a file', | |
30 | '-d' => 'is not a directory', | |
31 | '-l' => 'is not a link', | |
32 | '-S' => 'is not a socket', | |
33 | '-p' => 'is not a named pipe', | |
34 | '-b' => 'is not a block special file', | |
35 | '-c' => 'is not a character special file', | |
36 | '-u' => 'is not setuid', | |
37 | '-g' => 'is not setgid', | |
38 | '-k' => 'is not sticky', | |
39 | '-t' => 'is not a terminal file', | |
40 | '-T' => 'is not a text file', | |
41 | '-B' => 'is not a binary file', | |
42 | '-M' => 'has no modification date/time', | |
43 | '-A' => 'has no access date/time', | |
44 | '-C' => 'has no inode change date/time', | |
45 | ); | |
46 | ||
47 | # Documentation after __END__ | |
48 | ||
49 | sub import { | |
50 | if (defined $_[1] and $_[1] eq 'as_default') { | |
51 | local $^W = 0; | |
52 | package Tk; | |
53 | *FDialog = \&Tk::FileSelect::FDialog; | |
54 | *MotifFDialog = \&Tk::FileSelect::FDialog; | |
55 | } | |
56 | } | |
57 | ||
58 | sub Cancel | |
59 | { | |
60 | my ($cw) = @_; | |
61 | $cw->{Selected} = undef; | |
62 | $cw->withdraw unless $cw->cget('-transient'); | |
63 | } | |
64 | ||
65 | sub Accept { | |
66 | ||
67 | # Accept the file or directory name if possible. | |
68 | ||
69 | my ($cw) = @_; | |
70 | ||
71 | my($path, $so) = ($cw->cget('-directory'), $cw->SelectionOwner); | |
72 | my $leaf = undef; | |
73 | my $leaves; | |
74 | ||
75 | if (defined $so and | |
76 | $so == $cw->Subwidget('dir_list')->Subwidget('listbox')) { | |
77 | $leaves = [$cw->Subwidget('dir_list')->getSelected]; | |
78 | $leaves = [$cw->Subwidget('dir_entry')->get] if !scalar(@$leaves); | |
79 | } else { | |
80 | $leaves = [$cw->Subwidget('file_list')->getSelected]; | |
81 | $leaves = [$cw->Subwidget('file_entry')->get] if !scalar(@$leaves); | |
82 | } | |
83 | ||
84 | foreach $leaf (@$leaves) | |
85 | { | |
86 | if (defined $leaf and $leaf ne '') { | |
87 | if (!$cw->cget('-create') || -e "$path/$leaf") | |
88 | { | |
89 | foreach (@{$cw->cget('-verify')}) { | |
90 | my $r = ref $_; | |
91 | if (defined $r and $r eq 'ARRAY') { | |
92 | #local $_ = $leaf; # use strict var problem here | |
93 | return if not &{$_->[0]}($cw, $path, $leaf, @{$_}[1..$#{$_}]); | |
94 | } else { | |
95 | my $s = eval "$_ '$path/$leaf'"; | |
96 | print $@ if $@; | |
97 | if (not $s) { | |
98 | my $err; | |
99 | if (substr($_,0,1) eq '!') | |
100 | { | |
101 | my $t = substr($_,1); | |
102 | if (exists $error_text{$t}) | |
103 | { | |
104 | $err = $error_text{$t}; | |
105 | $err =~ s/\b(?:no|not) //; | |
106 | } | |
107 | } | |
108 | $err = $error_text{$_} unless defined $err; | |
109 | $err = "failed '$_' test" unless defined $err; | |
110 | $cw->Error("'$leaf' $err."); | |
111 | return; | |
112 | } | |
113 | } | |
114 | } # forend | |
115 | } | |
116 | else | |
117 | { | |
118 | unless (-w $path) | |
119 | { | |
120 | $cw->Error("Cannot write to $path"); | |
121 | return; | |
122 | } | |
123 | } | |
124 | $leaf = $path . '/' . $leaf; | |
125 | } else { | |
126 | $leaf = undef; | |
127 | } | |
128 | } | |
129 | if (scalar(@$leaves)) | |
130 | { | |
131 | my $sm = $cw->Subwidget('file_list')->cget(-selectmode); | |
132 | $cw->{Selected} = $leaves; | |
133 | my $command = $cw->cget('-command'); | |
134 | $command->Call(@{$cw->{Selected}}) if defined $command; | |
135 | } | |
136 | ||
137 | } # end Accept | |
138 | ||
139 | sub Accept_dir | |
140 | { | |
141 | my ($cw,$new) = @_; | |
142 | my $dir = $cw->cget('-directory'); | |
143 | $cw->configure(-directory => "$dir/$new"); | |
144 | } | |
145 | ||
146 | sub Populate { | |
147 | ||
148 | my ($w, $args) = @_; | |
149 | ||
150 | require Tk::Listbox; | |
151 | require Tk::Button; | |
152 | require Tk::Dialog; | |
153 | require Tk::Toplevel; | |
154 | require Tk::LabEntry; | |
155 | require Cwd; | |
156 | ||
157 | $w->SUPER::Populate($args); | |
158 | $w->protocol('WM_DELETE_WINDOW' => ['Cancel', $w ]); | |
159 | ||
160 | $w->{'reread'} = 0; | |
161 | $w->withdraw; | |
162 | ||
163 | # Create directory/filter entry, place at the top. | |
164 | my $e = $w->Component( | |
165 | LabEntry => 'dir_entry', | |
166 | -textvariable => \$w->{DirectoryString}, | |
167 | -labelVariable => \$w->{Configure}{-dirlabel}, | |
168 | ); | |
169 | $e->pack(-side => 'top', -expand => 0, -fill => 'x'); | |
170 | $e->bind('<Return>' => [$w => 'validateDir', Ev(['get'])]); | |
171 | ||
172 | # Create file entry, place at the bottom. | |
173 | $e = $w->Component( | |
174 | LabEntry => 'file_entry', | |
175 | -textvariable => \$w->{Configure}{-initialfile}, | |
176 | -labelVariable => \$w->{Configure}{-filelabel}, | |
177 | ); | |
178 | $e->pack(-side => 'bottom', -expand => 0, -fill => 'x'); | |
179 | $e->bind('<Return>' => [$w => 'validateFile', Ev(['get'])]); | |
180 | ||
181 | # Create directory scrollbox, place at the left-middle. | |
182 | my $b = $w->Component( | |
183 | ScrlListbox => 'dir_list', | |
184 | -labelVariable => \$w->{Configure}{-dirlistlabel}, | |
185 | -scrollbars => 'se', | |
186 | ); | |
187 | $b->pack(-side => 'left', -expand => 1, -fill => 'both'); | |
188 | $b->bind('<Double-Button-1>' => [$w => 'Accept_dir', Ev(['getSelected'])]); | |
189 | ||
190 | # Add a label. | |
191 | ||
192 | my $f = $w->Frame(); | |
193 | $f->pack(-side => 'right', -fill => 'y', -expand => 0); | |
194 | $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-acceptlabel'}, | |
195 | -command => [ 'Accept', $w ], | |
196 | ); | |
197 | $b->pack(-side => 'top', -fill => 'x', -expand => 1); | |
198 | $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-cancellabel'}, | |
199 | -command => [ 'Cancel', $w ], | |
200 | ); | |
201 | $b->pack(-side => 'top', -fill => 'x', -expand => 1); | |
202 | $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-resetlabel'}, | |
203 | -command => [$w => 'configure','-directory','.'], | |
204 | ); | |
205 | $b->pack(-side => 'top', -fill => 'x', -expand => 1); | |
206 | $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-homelabel'}, | |
207 | -command => [$w => 'configure','-directory',$ENV{'HOME'}], | |
208 | ); | |
209 | $b->pack(-side => 'top', -fill => 'x', -expand => 1); | |
210 | ||
211 | # Create file scrollbox, place at the right-middle. | |
212 | ||
213 | $b = $w->Component( | |
214 | ScrlListbox => 'file_list', | |
215 | -labelVariable => \$w->{Configure}{-filelistlabel}, | |
216 | -scrollbars => 'se', | |
217 | ); | |
218 | $b->pack(-side => 'right', -expand => 1, -fill => 'both'); | |
219 | $b->bind('<Double-1>' => [$w => 'Accept']); | |
220 | ||
221 | # Create -very dialog. | |
222 | ||
223 | my $v = $w->Component( | |
224 | Dialog => 'dialog', | |
225 | -title => 'Verify Error', | |
226 | -bitmap => 'error', | |
227 | -buttons => ['Dismiss'], | |
228 | ); | |
229 | ||
230 | $w->ConfigSpecs( | |
231 | -width => [ ['file_list','dir_list'], undef, undef, 14 ], | |
232 | -height => [ ['file_list','dir_list'], undef, undef, 14 ], | |
233 | -directory => [ 'METHOD', undef, undef, '.' ], | |
234 | -initialdir => '-directory', | |
235 | -filelabel => [ 'PASSIVE', 'fileLabel', 'FileLabel', 'File' ], | |
236 | -initialfile => [ 'PASSIVE', undef, undef, '' ], | |
237 | -filelistlabel => [ 'PASSIVE', undef, undef, 'Files' ], | |
238 | -filter => [ 'METHOD', undef, undef, undef ], | |
239 | -defaultextension => [ 'METHOD', undef, undef, undef ], | |
240 | -regexp => [ 'METHOD', undef, undef, undef ], | |
241 | -dirlistlabel => [ 'PASSIVE', undef, undef, 'Directories'], | |
242 | -dirlabel => [ 'PASSIVE', undef, undef, 'Directory'], | |
243 | '-accept' => [ 'CALLBACK',undef,undef, undef ], | |
244 | -command => [ 'CALLBACK',undef,undef, undef ], | |
245 | -transient => [ 'PASSIVE', undef, undef, 1 ], | |
246 | -verify => [ 'PASSIVE', undef, undef, ['!-d'] ], | |
247 | -create => [ 'PASSIVE', undef, undef, 0 ], | |
248 | -acceptlabel => [ 'PASSIVE', undef, undef, 'Accept'], | |
249 | -cancellabel => [ 'PASSIVE', undef, undef, 'Cancel'], | |
250 | -resetlabel => [ 'PASSIVE', undef, undef, 'Reset'], | |
251 | -homelabel => [ 'PASSIVE', undef, undef, 'Home'], | |
252 | DEFAULT => [ 'file_list' ], | |
253 | ); | |
254 | $w->Delegates(DEFAULT => 'file_list'); | |
255 | ||
256 | return $w; | |
257 | ||
258 | } # end Populate | |
259 | ||
260 | sub translate | |
261 | { | |
262 | my ($bs,$ch) = @_; | |
263 | return "\\$ch" if (length $bs); | |
264 | return '.*' if ($ch eq '*'); | |
265 | return '.' if ($ch eq '?'); | |
266 | return "\\." if ($ch eq '.'); | |
267 | return "\\/" if ($ch eq '/'); | |
268 | return "\\\\" if ($ch eq '\\'); | |
269 | return $ch; | |
270 | } | |
271 | ||
272 | sub glob_to_re | |
273 | { | |
274 | my $regex = shift; | |
275 | $regex =~ s/(\\?)(.)/&translate($1,$2)/ge; | |
276 | return sub { shift =~ /^${regex}$/ }; | |
277 | } | |
278 | ||
279 | sub filter | |
280 | { | |
281 | my ($cw,$val) = @_; | |
282 | my $var = \$cw->{Configure}{'-filter'}; | |
283 | if (@_ > 1 || !defined($$var)) | |
284 | { | |
285 | $val = '*' unless defined $val; | |
286 | $$var = $val; | |
287 | $cw->{'match'} = glob_to_re($val) unless defined $cw->{'match'}; | |
288 | unless ($cw->{'reread'}++) | |
289 | { | |
290 | $cw->Busy; | |
291 | $cw->afterIdle(['reread',$cw,$cw->cget('-directory')]) | |
292 | } | |
293 | } | |
294 | return $$var; | |
295 | } | |
296 | ||
297 | sub regexp | |
298 | { | |
299 | my ($cw,$val) = @_; | |
300 | my $var = \$cw->{Configure}{'-regexp'}; | |
301 | if (@_ > 1) | |
302 | { | |
303 | $$var = $val; | |
304 | $cw->{'match'} = sub { shift =~ m|^${val}$| }; | |
305 | unless ($cw->{'reread'}++) | |
306 | { | |
307 | $cw->Busy; | |
308 | $cw->afterIdle(['reread',$cw]) | |
309 | } | |
310 | } | |
311 | return $$var; | |
312 | } | |
313 | ||
314 | sub defaultextension | |
315 | { | |
316 | my ($cw,$val) = @_; | |
317 | if (@_ > 1) | |
318 | { | |
319 | $val = ".$val" if ($val !~ /^\./); | |
320 | $cw->filter("*$val"); | |
321 | } | |
322 | else | |
323 | { | |
324 | $val = $cw->filter; | |
325 | my ($ext) = $val =~ /(\.[^\.]*)$/; | |
326 | return $ext; | |
327 | } | |
328 | } | |
329 | ||
330 | sub directory | |
331 | { | |
332 | my ($cw,$dir) = @_; | |
333 | my $var = \$cw->{Configure}{'-directory'}; | |
334 | if (@_ > 1 && defined $dir) | |
335 | { | |
336 | if (substr($dir,0,1) eq '~') | |
337 | { | |
338 | if (substr($dir,1,1) eq '/') | |
339 | { | |
340 | $dir = $ENV{'HOME'} . substr($dir,1); | |
341 | } | |
342 | else | |
343 | {my ($uid,$rest) = ($dir =~ m#^~([^/]+)(/.*$)#); | |
344 | $dir = (getpwnam($uid))[7] . $rest; | |
345 | } | |
346 | } | |
347 | $dir =~ s#([^/\\])[\\/]+$#$1#; | |
348 | if (-d $dir) | |
349 | { | |
350 | unless (Tk::tainting()) | |
351 | { | |
352 | my $pwd = Cwd::getcwd(); | |
353 | if (chdir( (defined($dir) ? $dir : '') ) ) | |
354 | { | |
355 | my $new = Cwd::getcwd(); | |
356 | if ($new) | |
357 | { | |
358 | $dir = $new; | |
359 | } | |
360 | else | |
361 | { | |
362 | carp "Cannot getcwd in '$dir'"; | |
363 | } | |
364 | chdir($pwd) || carp "Cannot chdir($pwd) : $!"; | |
365 | $cw->{Configure}{'-directory'} = $dir; | |
366 | } | |
367 | else | |
368 | { | |
369 | $cw->BackTrace("Cannot chdir($dir) :$!"); | |
370 | } | |
371 | } | |
372 | $$var = $dir; | |
373 | unless ($cw->{'reread'}++) | |
374 | { | |
375 | $cw->Busy; | |
376 | $cw->afterIdle(['reread',$cw]) | |
377 | } | |
378 | } | |
379 | } | |
380 | return $$var; | |
381 | } | |
382 | ||
383 | sub reread | |
384 | { | |
385 | my ($w) = @_; | |
386 | my $dir = $w->cget('-directory'); | |
387 | if (defined $dir) | |
388 | { | |
389 | if (!defined $w->cget('-filter') or $w->cget('-filter') eq '') | |
390 | { | |
391 | $w->configure('-filter', '*'); | |
392 | } | |
393 | my $dl = $w->Subwidget('dir_list'); | |
394 | $dl->delete(0, 'end'); | |
395 | my $fl = $w->Subwidget('file_list'); | |
396 | $fl->delete(0, 'end'); | |
397 | local *DIR; | |
398 | if (opendir(DIR, $dir)) | |
399 | { | |
400 | my $file = $w->cget('-initialfile'); | |
401 | my $seen = 0; | |
402 | my $accept = $w->cget('-accept'); | |
403 | foreach my $f (sort(readdir(DIR))) | |
404 | { | |
405 | next if ($f eq '.'); | |
406 | my $path = "$dir/$f"; | |
407 | if (-d $path) | |
408 | { | |
409 | $dl->insert('end', $f); | |
410 | } | |
411 | else | |
412 | { | |
413 | if (&{$w->{match}}($f)) | |
414 | { | |
415 | if (!defined($accept) || $accept->Call($path)) | |
416 | { | |
417 | $seen = $fl->index('end') if ($file && $f eq $file); | |
418 | $fl->insert('end', $f) | |
419 | } | |
420 | } | |
421 | } | |
422 | } | |
423 | closedir(DIR); | |
424 | if ($seen) | |
425 | { | |
426 | $fl->selectionSet($seen); | |
427 | $fl->see($seen); | |
428 | } | |
429 | else | |
430 | { | |
431 | $w->configure(-initialfile => undef) unless $w->cget('-create'); | |
432 | } | |
433 | } | |
434 | $w->{DirectoryString} = $dir . '/' . $w->cget('-filter'); | |
435 | } | |
436 | $w->{'reread'} = 0; | |
437 | $w->Unbusy; | |
438 | } | |
439 | ||
440 | sub validateDir | |
441 | { | |
442 | my ($cw,$name) = @_; | |
443 | my ($leaf,$base) = fileparse($name); | |
444 | if ($leaf =~ /[*?]/) | |
445 | { | |
446 | $cw->configure('-directory' => $base,'-filter' => $leaf); | |
447 | } | |
448 | else | |
449 | { | |
450 | $cw->configure('-directory' => $name); | |
451 | } | |
452 | } | |
453 | ||
454 | sub validateFile | |
455 | { | |
456 | my ($cw,$name) = @_; | |
457 | my $i = 0; | |
458 | my $n = $cw->index('end'); | |
459 | # See if it is an existing file | |
460 | for ($i= 0; $i < $n; $i++) | |
461 | { | |
462 | my $f = $cw->get($i); | |
463 | if ($f eq $name) | |
464 | { | |
465 | $cw->selection('set',$i); | |
466 | $cw->Accept; | |
467 | } | |
468 | } | |
469 | # otherwise allow if -create is set, directory is writable | |
470 | # and it passes filter and accept criteria | |
471 | if ($cw->cget('-create')) | |
472 | { | |
473 | my $path = $cw->cget('-directory'); | |
474 | if (-w $path) | |
475 | { | |
476 | if (&{$cw->{match}}($name)) | |
477 | { | |
478 | my $accept = $cw->cget('-accept'); | |
479 | my $full = "$path/$name"; | |
480 | if (!defined($accept) || $accept->Call($full)) | |
481 | { | |
482 | $cw->{Selected} = [$full]; | |
483 | $cw->Callback(-command => @{$cw->{Selected}}); | |
484 | } | |
485 | else | |
486 | { | |
487 | $cw->Error("$name is not 'acceptable'"); | |
488 | } | |
489 | } | |
490 | else | |
491 | { | |
492 | $cw->Error("$name does not match '".$cw->cget('-filter').'\''); | |
493 | } | |
494 | } | |
495 | else | |
496 | { | |
497 | $cw->Error("Directory '$path' is not writable"); | |
498 | return; | |
499 | } | |
500 | } | |
501 | } | |
502 | ||
503 | sub Error | |
504 | { | |
505 | my $cw = shift; | |
506 | my $msg = shift; | |
507 | my $dlg = $cw->Subwidget('dialog'); | |
508 | $dlg->configure(-text => $msg); | |
509 | $dlg->Show; | |
510 | } | |
511 | ||
512 | sub Show | |
513 | { | |
514 | my ($cw,@args) = @_; | |
515 | if ($cw->cget('-transient')) { | |
516 | $cw->Popup(@args); | |
517 | $cw->focus; | |
518 | $cw->waitVariable(\$cw->{Selected}); | |
519 | $cw->withdraw; | |
520 | return defined($cw->{Selected}) | |
521 | ? (wantarray) ? @{$cw->{Selected}} : $cw->{Selected}[0] | |
522 | : undef; | |
523 | } else { | |
524 | $cw->Popup(@args); | |
525 | } | |
526 | } | |
527 | ||
528 | sub FDialog | |
529 | { | |
530 | my($cmd, %args) = @_; | |
531 | if ($cmd =~ /Save/) | |
532 | { | |
533 | $args{-create} = 1; | |
534 | $args{-verify} = [qw(!-d -w)]; | |
535 | } | |
536 | delete $args{-filetypes}; | |
537 | delete $args{-force}; | |
538 | Tk::DialogWrapper('FileSelect',$cmd, %args); | |
539 | } | |
540 | ||
541 | 1; | |
542 | ||
543 | __END__ | |
544 | ||
545 | =cut | |
546 |