line
stmt
bran
cond
sub
pod
time
code
1
##################################################
2
##################################################
3
## ##
4
## JFileDialog v. 1.34 - a reusable Tk-widget ##
5
## (c) 1996-2007 by Jim Turner ##
6
## --Derived 12/11/96 by Jim W. Turner-- ##
7
## --from FileDialog ##
8
## ##
9
## by: Brent B. Powers ##
10
## Merrill Lynch ##
11
## powers@swaps-comm.ml.com ##
12
## ##
13
##################################################
14
##################################################
15
16
# Change History:
17
# Version 1.0 - Initial implementation
18
# 96 Jan 15 ringger@cs.rochester.edu - Fixed dialogue box creation.
19
# 96 Jan 15 ringger - Added option for selecting directories.
20
# 96 Feb 29 powers - Rewrote and componentized, and added a bunch of
21
# options. Now requires perl 5.002gamma
22
#
23
24
=head1 NAME
25
26
Tk::JFileDialog - A highly configurable File Dialog widget for Perl/Tk.
27
28
=head1 DESCRIPTION
29
30
The widget is composed of a number
31
of sub-widgets, namely, a listbox for files and (optionally) directories, an entry
32
for filename, an (optional) entry for pathname, an entry for a filter pattern, a 'ShowAll'
33
checkbox (for enabling display of .* files and directories), and three buttons, namely
34
OK, Rescan, and Cancel. Note that the labels for all subwidgets (including the text
35
for the buttons and Checkbox) are configurable for foreign language support.
36
37
=head1 SYNOPSIS
38
39
my $LoadDialog = $main->JFileDialog(
40
-Title =>'Please select a file:',
41
-Create => 0
42
);
43
44
=head2 Usage Description
45
46
To use FileDialog, simply create your FileDialog objects during initialization (or at
47
least before a Show). When you wish to display the FileDialog, invoke the 'Show' method
48
on the FileDialog object; The method will return either a file name, a path name, or
49
undef. undef is returned only if the user pressed the Cancel button.
50
51
=head2 Example Code
52
53
The following code creates a FileDialog and calls it. Note that perl5.002gamma is
54
required.
55
56
=item
57
58
#!/usr/local/bin/perl -w
59
60
use Tk;
61
use Tk::JFileDialog;
62
use strict;
63
64
my($main) = MainWindow->new;
65
my($Horiz) = 1;
66
my($fname);
67
68
my($LoadDialog) = $main->JFileDialog(-Title =>'This is my title',
69
-Create => 0);
70
71
$LoadDialog->configure(-FPat => '*pl',
72
-ShowAll => 'NO');
73
74
$main->Entry(-textvariable => \$fname)
75
->pack(-expand => 1,
76
-fill => 'x');
77
78
$main->Button(-text => 'Kick me!',
79
-command => sub {
80
$fname = $LoadDialog->Show(-Horiz => $Horiz);
81
if (!defined($fname)) {
82
$fname = "Fine,Cancel, but no Chdir anymore!!!";
83
$LoadDialog->configure(-Chdir =>'NO');
84
}
85
})
86
->pack(-expand => 1,
87
-fill => 'x');
88
89
$main->Checkbutton(-text => 'Horizontal',
90
-variable => \$Horiz)
91
->pack(-expand => 1,
92
-fill => 'x');
93
94
$main->Button(-text => 'Exit',
95
-command => sub {
96
$main->destroy;
97
})
98
->pack(-expand => 1,
99
-fill => 'x');
100
101
MainLoop;
102
103
print "Exit Stage right!\n";
104
105
exit;
106
107
=head1 METHODS
108
109
The following non-standard method may be used with a FileDialog object
110
111
=head2 Show
112
113
=over 4
114
115
Displays the file dialog box for the user to operate. Additional configuration
116
items may be passed in at Show-time In other words, this code snippet:
117
118
$fd->Show(-Title => 'Ooooh, Preeeeeety!');
119
120
is the same as this code snippet:
121
122
$fd->configure(-Title => 'Ooooh, Preeeeeety!');
123
$fd->Show;
124
125
=head1 CONFIGURATION
126
127
Any of the following configuration items may be set via the configure (or Show) method,
128
or retrieved via the cget method.
129
130
=head2 I
131
132
Flags may be configured with either 1,'true', or 'yes' for 1, or 0, 'false', or 'no'
133
for 0. Any portion of 'true', 'yes', 'false', or 'no' may be used, and case does not
134
matter.
135
136
=head2 -Chdir
137
138
Enable the user to change directories. The default is 1. If disabled, the directory
139
list box will not be shown.
140
141
=head2 -Create
142
143
Enable the user to specify a file that does not exist. If not enabled, and the user
144
specifies a non-existent file, a dialog box will be shown informing the user of the
145
error (This Dialog Box is configurable via the EDlg* switches, below).
146
147
default: 1
148
149
=head2 -ShowAll
150
151
Determines whether hidden files (.*) are displayed in the File and Directory Listboxes.
152
The default is 0. The Show All Checkbox reflects the setting of this switch.
153
154
=head2 -DisableShowAll
155
156
Disables the ability of the user to change the status of the ShowAll flag. The default
157
is 0 (the user is by default allowed to change the status).
158
159
=head2 -DisableFPat
160
161
Disables the ability of the user to change the file selection pattern. The default
162
is 0 (the user is by default allowed to change the status).
163
164
=head2 -Grab
165
166
Enables the File Dialog to do an application Grab when displayed. The default is 1.
167
168
=head2 -History
169
170
Used with the "-HistFile" option. Specifies how many files to retain in the
171
history list. The default is 0 (keep all).
172
173
=head2 -HistDeleteOk
174
175
If set, allows user to delete items from the history dropdown list and thus the
176
history file.
177
178
=head2 -HistUsePath
179
180
If set, the path is set to that of the last file selected from the history.
181
182
=head2 -HistUsePathButton
183
184
If set, the path is set to that of the last file selected from the history.
185
186
=head2 -HistFile
187
188
Enables the keeping of a history of the previous files / directories selected.
189
The file specified must be writable. If specified, a history of up to
190
"-History" number of files will be kept and will be displayed in a "JBrowseEntry"
191
combo-box permitting user selection.
192
193
=head2 -PathFile
194
195
Specifies a file containing a list of "favorite paths" bookmarks to show in a
196
dropdown list allowing quick-changes in directories.
197
198
=head2 -Horiz
199
200
True sets the File List box to be to the right of the Directory List Box. If 0, the
201
File List box will be below the Directory List box. The default is 1.
202
203
=head2 -QuickSelect
204
205
Default 1, if set to 0, user must invoke the "OK" button to complete selection.
206
If 1 or 2, clicking item in the history menu automatically completes the
207
selection. If 2, single-clicking a file in the file list completes selection
208
(otherwise, a double-click is required).
209
210
=head2 -SelDir
211
212
If 1 or 2, enables selection of a directory rather than a file, and disables the
213
actions of the File List Box. Setting to 2 allows selection of either a file OR a directory. The default is 0.
214
215
=head2 I
216
217
=head2 -FPat
218
219
Sets the default file selection pattern. The default is '*'. Only files matching
220
this pattern will be displayed in the File List Box.
221
222
=head2 -Geometry
223
224
Sets the geometry of the File Dialog. Setting the size is a dangerous thing to do.
225
If not configured, or set to '', the File Dialog will be centered.
226
227
=head2 -SelHook
228
229
SelHook is configured with a reference to a routine that will be called when a file
230
is chosen. The file is called with a sole parameter of the full path and file name
231
of the file chosen. If the Create flag is disabled (and the user is not allowed
232
to specify new files), the file will be known to exist at the time that SelHook is
233
called. Note that SelHook will also be called with directories if the SelDir Flag
234
is enabled, and that the FileDialog box will still be displayed. The FileDialog box
235
should B be destroyed from within the SelHook routine, although it may generally
236
be configured.
237
238
SelHook routines return 0 to reject the selection and allow the user to reselect, and
239
any other value to accept the selection. If a SelHook routine returns non-zero, the
240
FileDialog will immediately be withdrawn, and the file will be returned to the caller.
241
242
There may be only one SelHook routine active at any time. Configuring the SelHook
243
routine replaces any existing SelHook routine. Configuring the SelHook routine with
244
0 removes the SelHook routine. The default SelHook routine is undef.
245
246
=head2 I
247
248
The following two switches may be used to set default variables, and to get final
249
values after the Show method has returned (but has not been explicitly destroyed
250
by the caller)
251
252
=head2 -SelectMode
253
254
Sets the selectmode of the File Dialog. If not configured it will be defaulted
255
to 'single'. If set to 'multiple', then the user may select more than one file
256
and a comma-delimited list of all selected files is returned. Otherwise, only
257
a single file may be selected.
258
259
B<-File> The file selected, or the default file. The default is ''.
260
261
B<-Path> The path of the selected file, or the initial path. The default is $ENV{'HOME'}.
262
263
=head2 I
264
265
For support of internationalization, the text on any of the subwidgets may be
266
changed.
267
268
B<-Title> The Title of the dialog box. The default is 'Select File:'.
269
270
B<-DirLBCaption> The Caption above the Directory List Box. The default is 'Directories'.
271
272
B<-FileLBCaption> The Caption above the File List Box. The default is 'Files'.
273
274
B<-FileEntryLabel> The label to the left of the File Entry. The Default is 'Filename:'.
275
276
B<-PathEntryLabel> The label to the left of the Path Entry. The default is 'Pathname:'.
277
278
B<-FltEntryLabel> The label to the left of the Filter entry. The default is 'Filter:'.
279
280
B<-ShowAllLabel> The text of the Show All Checkbutton. The default is 'Show All'.
281
282
=head2 I
283
284
For support of internationalization, the text on the three buttons may be changed.
285
286
B<-OKButtonLabel> The text for the OK button. The default is 'OK'.
287
288
B<-RescanButtonLabel> The text for the Rescan button. The default is 'Refresh'.
289
290
B<-CancelButtonLabel> The text for the Cancel button. The default is 'Cancel'.
291
292
B<-HomeButtonLabel> The text for the Home directory button. The default is 'Home'.
293
294
B<-CWDButtonLabel> The text for the Current Working Directory button.
295
The default is 'C~WD'.
296
297
B<-SortButton> Whether or not to display a checkbox to change file box list sort order (default=1 show).
298
299
B<-SortButtonLabel> The text for the Sort/Atime button. The default is 'Atime'.
300
301
B<-SortOrder> Order to display files in the file list box ('Name' or 'Date' default=Name).
302
If 'Date', then the day and time is displayed in the box before the name,
303
(but not included when selected)
304
305
=head2 I
306
307
If the Create switch is set to 0, and the user specifies a file that does not exist,
308
a dialog box will be displayed informing the user of the error. These switches allow
309
some configuration of that dialog box.
310
311
=head2 -EDlgTitle
312
313
The title of the Error Dialog Box. The default is 'File does not exist!'.
314
315
=head2 -EDlgText
316
317
The message of the Error Dialog Box. The variables $path, $file, and $filename
318
(the full path and filename of the selected file) are available. The default
319
is I<"You must specify an existing file.\n(\$filename not found)">
320
321
=head1 Author
322
323
B
324
325
turnerjw at mesh . net
326
327
A derived work from Tk::FileDialog, by:
328
329
B
330
331
powers@ml.com
332
333
This code may be distributed under the same conditions as Perl itself.
334
335
=cut
336
337
package Tk::JFileDialog;
338
339
1
1
1849
use vars qw($VERSION);
1
1
1
76
340
$VERSION = '1.6';
341
342
require 5.002;
343
1
1
7478
use Tk;
0
0
344
use Tk::JDialog;
345
use Tk::JBrowseEntry;
346
use Carp;
347
use strict;
348
use Cwd;
349
use File::Glob;
350
my $useAutoScroll = 0;
351
eval 'use Tk::Autoscroll; $useAutoScroll = 1; 1';
352
353
my $Win32 = 0;
354
$Win32 = ($^O =~ /Win/i) ? 1 : 0;
355
356
my $driveletter = '';
357
358
@Tk::JFileDialog::ISA = qw(Tk::Toplevel);
359
360
Tk::Widget->Construct('JFileDialog');
361
362
### Global Variables (Convenience only)
363
my(@topPack) = (-side => 'top', -anchor => 'center');
364
my(@rightPack) = (-side => 'right', -anchor => 'center');
365
my(@leftPack) = (-side => 'left', -anchor => 'center');
366
my(@xfill) = (-fill => 'x');
367
my(@yfill) = (-fill => 'y');
368
my(@bothFill) = (-fill => 'both');
369
my(@expand) = (-expand => 1);
370
my(@raised) = (-relief => 'raised');
371
my(@sunken) = (-relief => 'sunken');
372
my (@driveletters);
373
my ($cwdDfltDrive);
374
375
376
sub Populate
377
{
378
## File Dialog constructor, inherits new from Toplevel
379
my($FDialog, @args) = @_;
380
381
$FDialog->SUPER::Populate(@args);
382
$FDialog->{Configure}{-SortButton} = 1; #DEFAULT UNLESS SET BY USER TO ZERO!
383
foreach my $i (keys %{$args[0]})
384
{
385
#x if ($i eq '-HistFile' || $i eq '-History' || $i eq 'QuickSelect'
386
#x || $i eq '-PathFile' || $i eq '-HistDeleteOk'
387
#x || $i eq '-HistUsePath' || $i eq '-HistUsePathButton')
388
if ($i =~ /^\-(?:HistFile|History|QuickSelect|PathFile|HistDeleteOk|HistUsePath|HistUsePathButton|SortButton|SelDir)$/)
389
{
390
$FDialog->{Configure}{$i} = $args[0]->{$i};
391
}
392
}
393
$FDialog->bind("",sub
394
{
395
my $self = shift;
396
$self->focusPrev();
397
Tk->break;
398
});
399
400
$FDialog->withdraw;
401
402
if ($^O =~ /Win/i)
403
{
404
$cwdDfltDrive = substr(&cwd(),0,2);
405
$cwdDfltDrive ||= substr(&getcwd(),0,2);
406
}
407
else
408
{
409
$FDialog->protocol('WM_DELETE_WINDOW' => sub
410
{
411
if (defined($FDialog->{'Can'}) && $FDialog->{'Can'}->IsWidget )
412
{
413
$FDialog->{'Can'}->invoke;
414
}
415
}
416
);
417
#JWT??? $FDialog->transient($FDialog->toplevel);
418
}
419
## Initialize variables that won't be initialized later
420
$FDialog->{'Retval'} = -1;
421
$FDialog->{'DFFrame'} = 0;
422
423
$FDialog->{Configure}{-Horiz} = 1;
424
$FDialog->{Configure}{-SortOrder} = 'Name';
425
426
$FDialog->BuildFDWindow;
427
#$FDialog->{'activefore'} = $FDialog->{'SABox'}->cget(-foreground);
428
$FDialog->{'inactivefore'} = $FDialog->{'SABox'}->cget(-disabledforeground);
429
430
$FDialog->ConfigSpecs(-Chdir => ['PASSIVE', undef, undef, 1],
431
-Create => ['PASSIVE', undef, undef, 1],
432
-DisableShowAll => ['PASSIVE', undef, undef, 0],
433
-DisableFPat => ['PASSIVE', undef, undef, 0],
434
-FPat => ['PASSIVE', undef, undef, '*'],
435
-File => ['PASSIVE', undef, undef, ''],
436
-Geometry => ['PASSIVE', undef, undef, undef],
437
-Grab => ['PASSIVE', undef, undef, 1],
438
-Horiz => ['PASSIVE', undef, undef, 1],
439
-Path => ['PASSIVE', undef, undef, "$ENV{'HOME'}"],
440
-SelDir => ['PASSIVE', undef, undef, 0],
441
-SortButton => ['PASSIVE', undef, undef, 1],
442
-SortOrder => ['PASSIVE', undef, undef, 'Name'],
443
-DirLBCaption => ['PASSIVE', undef, undef, 'Directories:'],
444
-FileLBCaption => ['PASSIVE', undef, undef, 'Files:'],
445
-FileEntryLabel => ['METHOD', undef, undef, 'Filename:'],
446
-PathEntryLabel => ['METHOD', undef, undef, 'Pathname:'],
447
-HistEntryLabel => ['METHOD', undef, undef, 'History:'],
448
-FavEntryLabel => ['METHOD', undef, undef, 'Favorite Paths:'],
449
-FltEntryLabel => ['METHOD', undef, undef, 'Filter:'],
450
-ShowAllLabel => ['METHOD', undef, undef, 'ShowAll'],
451
-OKButtonLabel => ['METHOD', undef, undef, '~OK'],
452
-RescanButtonLabel => ['METHOD', undef, undef, '~Refresh'],
453
-SortButtonLabel => ['METHOD', undef, undef, '~Atime'],
454
-CancelButtonLabel => ['METHOD', undef, undef, '~Cancel'],
455
-HomeButtonLabel => ['METHOD', undef, undef, '~Home'],
456
-CWDButtonLabel => ['METHOD', undef, undef, 'C~WD'],
457
-SelHook => ['PASSIVE', undef, undef, undef],
458
-SelectMode => ['PASSIVE', undef, undef, 'single'], #ADDED 20050416 TO PERMIT MULTIFILE SELECTIONS, THANKS TO Paul Falbe FOR THIS PATCH!
459
-ShowAll => ['PASSIVE', undef, undef, 0],
460
-Title => ['PASSIVE', undef, undef, "Select File:"],
461
-EDlgTitle => ['PASSIVE', undef, undef,
462
'File does not exist!'],
463
-History => ['PASSIVE', undef, undef, 0],
464
-HistFile => ['PASSIVE', undef, undef, undef],
465
-HistDeleteOk => ['PASSIVE', undef, undef, undef],
466
-HistUsePath => ['PASSIVE', undef, undef, undef],
467
-HistUsePathButton => ['PASSIVE', undef, undef, 0],
468
-PathFile => ['PASSIVE', undef, undef, undef],
469
-QuickSelect => ['PASSIVE', undef, undef, 1],
470
-DestroyOnHide => ['PASSIVE', undef, undef, 0],
471
-EDlgText => ['PASSIVE', undef, undef,
472
"You must specify an existing file.\n"
473
. "(\$filename not found)"]);
474
}
475
476
### A few methods for configuration
477
sub OKButtonLabel
478
{
479
&SetButton('OK',@_);
480
}
481
sub RescanButtonLabel
482
{
483
&SetButton('Rescan',@_);
484
}
485
sub SortButtonLabel
486
{
487
my $self = $_[0];
488
&SetButton('SortxButton',@_) if (defined $self->{'SortxButton'}) ;
489
}
490
sub CancelButtonLabel
491
{
492
&SetButton('Can',@_);
493
}
494
sub HomeButtonLabel
495
{
496
&SetButton('Home',@_);
497
}
498
sub CWDButtonLabel
499
{
500
&SetButton('Current',@_);
501
}
502
503
sub SetButton
504
{
505
my($widg, $self, $title) = @_;
506
if (defined($title))
507
{
508
my ($underlinepos) = ($title =~ s/^(.*)~/$1/) ? length($1): undef;
509
## This is a configure
510
$self->{$widg}->configure(-text => $title);
511
if (defined($underlinepos) && $underlinepos >= 0)
512
{
513
$self->{$widg}->configure(-underline => $underlinepos);
514
my ($mychar) = substr($title,$underlinepos,1);
515
$self->bind("",sub {$self->{$widg}->Invoke;});
516
}
517
}
518
## Return the current value
519
$self->{$widg}->cget(-text);
520
$self->{$widg}->bind("",sub {$self->{$widg}->Invoke;});
521
}
522
523
sub HistEntryLabel
524
{
525
&SetLabel('HEF', @_);
526
}
527
sub FavEntryLabel
528
{
529
&SetLabel('FAV', @_);
530
}
531
sub FileEntryLabel
532
{
533
&SetLabel('FEF', @_);
534
}
535
sub PathEntryLabel
536
{
537
&SetLabel('PEF', @_);
538
}
539
sub FltEntryLabel
540
{
541
&SetLabel('patFrame', @_);
542
}
543
sub ShowAllLabel
544
{
545
&SetButton('SABox', @_);
546
}
547
sub SetLabel
548
{
549
my($widg, $self, $title) = @_;
550
if (defined($title))
551
{
552
## This is a configure
553
$self->{$widg}->{'Label'}->configure(-text => $title);
554
}
555
## Return the current value
556
$self->{$widg}->{'Label'}->cget(-text);
557
}
558
559
sub SetFlag
560
{
561
## Set the given flag to either 1 or 0, as appropriate
562
my($self, $flag, $dflt) = @_;
563
564
$flag = "-$flag";
565
566
## We know it's defined as there was a ConfigDefault call after the Populate
567
## call. Therefore, all we have to do is parse the non-numerics
568
if (&IsNum($self->{Configure}{$flag}))
569
{
570
$self->{Configure}{$flag} = 1 unless $self->{Configure}{$flag} == 0;
571
}
572
else
573
{
574
my($val) = $self->{Configure}{$flag};
575
576
my($fc) = lc(substr($val,0,1));
577
578
if (($fc eq 'y') || ($fc eq 't'))
579
{
580
$val = 1;
581
}
582
elsif (($fc eq 'n') || ($fc eq 'f'))
583
{
584
$val = 0;
585
}
586
else
587
{
588
## bad value, complain about it
589
carp ("\"$val\" is not a valid flag ($flag)!");
590
$dflt = 0 if !defined($dflt);
591
$val = $dflt;
592
}
593
$self->{Configure}{$flag} = $val;
594
}
595
return $self->{Configure}{$flag};
596
}
597
598
sub Show
599
{
600
my ($self) = shift;
601
602
my $old_focus = $self->focusSave;
603
my $old_grab = $self->grabSave;
604
$self->configure(@_);
605
606
## Clean up flag variables
607
$self->SetFlag('Chdir');
608
$self->SetFlag('Create');
609
$self->SetFlag('ShowAll');
610
$self->SetFlag('DisableShowAll');
611
$self->SetFlag('DisableFPat'); #ADDED 20050126.
612
$self->SetFlag('Horiz');
613
$self->SetFlag('Grab');
614
#$self->SetFlag('SelDir');
615
616
## Set up, or remove, the directory box
617
&BuildListBoxes($self);
618
## Enable, or disable, the show all box
619
if ($self->{Configure}{-DisableShowAll})
620
{
621
$self->{'SABox'}->configure(-state => 'disabled');
622
}
623
else
624
{
625
$self->{'SABox'}->configure(-state => 'normal');
626
}
627
$self->{'FPat'}->configure(-state => ($self->{Configure}{-DisableFPat})
628
? 'disabled' : 'normal'); #ADDED 20050126.
629
## Enable or disable the file entry box
630
if ($self->{Configure}{-SelDir} == 1)
631
{
632
$self->{Configure}{-File} = '';
633
$self->{'FileEntry'}->configure(-state => 'disabled',
634
-foreground => $self->{'inactivefore'});
635
$self->{'FileList'}->configure(-selectforeground => $self->{'inactivefore'});
636
$self->{'FileList'}->configure(-foreground => $self->{'inactivefore'});
637
}
638
## Set the title
639
$self->title($self->{Configure}{-Title});
640
641
## Create window position (Center unless configured)
642
$self->update;
643
if (defined($self->{Configure}{-Geometry}))
644
{
645
$self->geometry($self->{Configure}{-Geometry});
646
}
647
else
648
{
649
my($x,$y);
650
$x = int(($self->screenwidth - $self->reqwidth)/2 - $self->parent->vrootx);
651
$y = int(($self->screenheight - $self->reqheight)/2 - $self->parent->vrooty);
652
$self->geometry("+$x+$y");
653
}
654
655
## Fill the list boxes
656
&RescanFiles($self);
657
## Restore the window, and go
658
$self->update;
659
$self->deiconify;
660
661
## Set up the grab
662
$self->grab if ($self->{Configure}{-Grab});
663
664
## Initialize status variables
665
$self->{'Retval'} = 0;
666
$self->{'RetFile'} = "";
667
668
if ($self->{Configure}{-SelDir} == 1) # !!!
669
{
670
$self->{'DirEntry'}->focus;
671
}
672
else
673
{
674
$self->{'FileEntry'}->focus;
675
}
676
select(undef, undef, undef, 0.1) if ($ENV{DESKTOP_SESSION} =~ /AfterStep version 2.2.1[2-9]/i); #JWT:ADDED FANCY SLEEP FUNCTION 20140606 B/C TO GET AFTERSTEP TO GIVE "TRANSIENT" WINDOWS THE FOCUS?!;
677
my($i) = 0;
678
while (!$i)
679
{
680
$self->tkwait('variable',\$self->{'Retval'});
681
$i = $self->{'Retval'};
682
if ($i != -1)
683
{
684
## No cancel, so call the hook if it's defined
685
if (defined($self->{Configure}{-SelHook}))
686
{
687
## The hook returns 0 to ignore the result,
688
## non-zero to accept. Must release the grab before calling
689
$self->grab('release') if (defined($self->grab('current')));
690
691
$i = &{$self->{Configure}{-SelHook}}($self->{'RetFile'});
692
693
$self->grab if ($self->{Configure}{-Grab});
694
}
695
}
696
else
697
{
698
$self->{'RetFile'} = undef;
699
}
700
}
701
702
$self->grab('release') if (defined($self->grab('current')));
703
&$old_focus;
704
&$old_grab;
705
# $self->parent->focus();
706
($self->{Configure}{-DestroyOnHide} == 1) ? $self->destroy : $self->withdraw;
707
return $self->{'RetFile'};
708
}
709
710
sub getLastPath
711
{
712
my ($self) = shift;
713
714
my $path = $self->{Configure}{-Path};
715
$path = $driveletter . $path if ($driveletter && $^O =~ /Win/i);
716
return $path;
717
}
718
719
sub getHistUsePathButton
720
{
721
my ($self) = shift;
722
723
return 0 unless (defined $self->{"histToggleVal"});
724
return $self->{"histToggleVal"};
725
}
726
727
#### PRIVATE METHODS AND SUBROUTINES ####
728
sub IsNum
729
{
730
my($parm) = @_;
731
my($warnSave) = $;
732
$ = 0;
733
my($res) = (($parm + 0) eq $parm);
734
$ = $warnSave;
735
return $res;
736
}
737
738
sub BuildListBox
739
{
740
my($self, $fvar, $flabel, $listvar,$hpack, $vpack) = @_;
741
742
## Create the subframe
743
#$self->{"$fvar"} = $self->{'DFFrame'}->Frame(-setgrid => 1)
744
$self->{"$fvar"} = $self->{'DFFrame'}->Frame
745
->pack(-side => $self->{Configure}{-Horiz} ? $hpack : $vpack,
746
-anchor => 'center',
747
-padx => '4m', # !!!
748
-pady => '2m',
749
@bothFill, @expand);
750
751
## Create the label
752
$self->{"$fvar"}->Label(-text => "$flabel")
753
->pack(@topPack, @xfill);
754
755
## Create the frame for the list box
756
my($fbf) = $self->{"$fvar"}->Frame
757
->pack(@topPack, @bothFill, @expand);
758
759
## And the scrollbar and listbox in it
760
# $self->{"$listvar"} = $fbf->Listbox(@raised, -exportselection => 0)
761
# ->pack(@leftPack, @expand, @bothFill);
762
763
# $fbf->AddScrollbars($self->{"$listvar"});
764
# $fbf->configure(-scrollbars => 'se');
765
$self->{"$listvar"} = $fbf->Scrolled('Listbox', -scrollbars => 'se', @raised,
766
-exportselection => 0)->pack(@leftPack, @expand, @bothFill);
767
768
$self->{"$listvar"}->Subwidget('xscrollbar')->configure(-takefocus => 0);
769
$self->{"$listvar"}->Subwidget('yscrollbar')->configure(-takefocus => 0);
770
Tk::Autoscroll::Init($self->{"$listvar"}) if ($useAutoScroll);
771
$self->{"$listvar"}->bind('', sub { $self->bind('', [ sub { $self->{"$listvar"}->yview('scroll',-($_[1]/120)*1,'units') }, Tk::Ev("D")]); });
772
$self->{"$listvar"}->bind('', sub { $self->bind('', [ sub { Tk->break; }]) });
773
774
#NEXT LINE ADDED 20050416 TO PERMIT MULTIFILE SELECTIONS, THANKS TO Paul Falbe FOR THIS PATCH!
775
$self->{"$listvar"}->configure(-selectmode => $self->{Configure}{-SelectMode});
776
}
777
778
sub BindDir
779
{
780
### Set up the bindings for the directory selection list box
781
my($self) = @_;
782
783
my($lbdir) = $self->{'DirList'};
784
#$lbdir->bind("" => sub
785
$lbdir->bind("", sub #CHGD. 20020122 TO MAKE SINGLE-CLICK CHDIR.
786
{
787
my($np) = $lbdir->curselection;
788
return if !defined($np);
789
$np = $lbdir->get($np);
790
if ($np eq '..')
791
{
792
## Moving up one directory
793
$_ = $self->{Configure}{-Path};
794
chop if m!/$!;
795
s!(.*/)[^/]*$!$1!;
796
$self->{Configure}{-Path} = $_;
797
}
798
elsif ($np eq "/")
799
{
800
## Moving to root directory
801
$self->{Configure}{-Path} = $np;
802
}
803
else
804
{
805
## Going down into a directory
806
$self->{Configure}{-Path} .= "/" . "$np/" unless ($np eq '.');
807
}
808
$self->{Configure}{-Path} =~ s!//*!/!g;
809
\&RescanFiles($self);
810
}
811
);
812
$lbdir->bind("" => sub
813
{
814
my($np) = $lbdir->index('active');
815
return if !defined($np);
816
$np = $lbdir->get($np);
817
if ($np eq "..")
818
{
819
## Moving up one directory
820
$_ = $self->{Configure}{-Path};
821
chop if m!/$!;
822
s!(.*/)[^/]*$!$1!;
823
$self->{Configure}{-Path} = $_;
824
}
825
elsif ($np eq "/")
826
{
827
## Moving to root directory
828
$self->{Configure}{-Path} = $np;
829
}
830
else
831
{
832
## Going down into a directory
833
$self->{Configure}{-Path} .= "/" . "$np/" unless ($np eq '.');
834
}
835
$self->{Configure}{-Path} =~ s!//*!/!g;
836
\&RescanFiles($self);
837
}
838
);
839
$self->{'DirEntry'}->bind('' => [\&keyFn,\$self->{Configure}{'Path'},$self->{'DirList'}]);
840
}
841
842
sub BindFile
843
{
844
### Set up the bindings for the file selection list box
845
my($self) = @_;
846
847
## A single click selects the file...
848
$self->{'FileList'}->bind("", sub
849
{
850
if ($self->{Configure}{-SelDir} != 1)
851
{
852
# $self->{Configure}{-File} =
853
# $self->{'FileList'}->get($self->{'FileList'}->curselection);
854
#PREV. CHGD. TO NEXT 20050416 TO PERMIT MULTIFILE SELECTIONS, THANKS TO Paul Falbe FOR THIS PATCH!
855
$self->{Configure}{-File} = join ",", map { (my $f = $self->{'FileList'}->get($_)) =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o; $f }
856
$self->{'FileList'}->curselection;
857
}
858
}
859
);
860
## A double-click selects the file for good
861
if ($self->{Configure}{-QuickSelect} == 2)
862
{
863
$self->{'FileList'}->bind("<1>", sub
864
{
865
if ($self->{Configure}{-SelDir} != 1)
866
{
867
my($f) = $self->{'FileList'}->curselection;
868
return if !defined($f);
869
#$self->{'File'} = $self->{'FileList'}->get($f);
870
($self->{Configure}{-File} = $self->{'FileList'}->get($f)) =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o;
871
$self->{'OK'}->invoke;
872
}
873
}
874
);
875
}
876
elsif ($self->{Configure}{-QuickSelect})
877
{
878
$self->{'FileList'}->bind("", sub
879
{
880
if ($self->{Configure}{-SelDir} != 1)
881
{
882
my($f) = $self->{'FileList'}->curselection;
883
return if !defined($f);
884
($self->{'File'} = $self->{'FileList'}->get($f)) =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o;
885
$self->{'OK'}->invoke;
886
}
887
}
888
);
889
}
890
$self->{'FileList'}->bind("", sub
891
{
892
if ($self->{Configure}{-SelDir} != 1)
893
{
894
my($f) = $self->{'FileList'}->index('active');
895
return if !defined($f);
896
($self->{'File'} = $self->{'FileList'}->get($f)) =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o;
897
# $self->{Configure}{-File} = $self->{'FileList'}->get($f);
898
#PREV. CHGD. TO NEXT 20050416 TO PERMIT MULTIFILE SELECTIONS, THANKS TO Paul Falbe FOR THIS PATCH!
899
$self->{Configure}{-File} = join ",", map { (my $f = $self->{'FileList'}->get($_)) =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o; $f }
900
$self->{'FileList'}->curselection;
901
$self->{Configure}{-File} ||= $self->{'File'};
902
$self->{'OK'}->focus;
903
# $self->{'OK'}->invoke;
904
}
905
}
906
);
907
$self->{'FileList'}->bind("", sub
908
{
909
if ($self->{Configure}{-SelDir} != 1)
910
{
911
my($f) = $self->{'FileList'}->index('active');
912
return if !defined($f);
913
($self->{'File'} = $self->{'FileList'}->get($f)) =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o;
914
# $self->{Configure}{-File} = $self->{'FileList'}->get($f);
915
#PREV. CHGD. TO NEXT 20050416 TO PERMIT MULTIFILE SELECTIONS, THANKS TO Paul Falbe FOR THIS PATCH!
916
$self->{Configure}{-File} = join ",", map { (my $f = $self->{'FileList'}->get($_)) =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o; $f }
917
$self->{'FileList'}->curselection;
918
}
919
}
920
);
921
$self->{'FileList'}->bind("", sub
922
{
923
if ($self->{Configure}{-SelDir} != 1)
924
{
925
my($f) = $self->{'FileList'}->index('active');
926
return if !defined($f);
927
($self->{'File'} = $self->{'FileList'}->get($f)) =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o;
928
# $self->{Configure}{-File} = $self->{'FileList'}->get($f);
929
#PREV. CHGD. TO NEXT 20050416 TO PERMIT MULTIFILE SELECTIONS, THANKS TO Paul Falbe FOR THIS PATCH!
930
$self->{Configure}{-File} = join ",", map { (my $f = $self->{'FileList'}->get($_)) =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o; $f }
931
$self->{'FileList'}->curselection;
932
}
933
}
934
);
935
#$self->{'FileList'}->configure(-selectforeground => 'blue');
936
$self->{'FileEntry'}->bind('' => [\&keyFn,\$self->{Configure}{'File'},$self->{'FileList'}]);
937
}
938
939
sub BuildEntry
940
{
941
### Build the entry, label, and frame indicated. This is a
942
### convenience routine to avoid duplication of code between
943
### the file and the path entry widgets
944
my($self, $LabelVar, $entry) = @_;
945
my($LabelType) = $LabelVar;
946
$LabelVar = "-$LabelVar";
947
948
## Create the entry frame
949
my $eFrame = $self->Frame(@raised)
950
->pack(-padx => '4m', -ipady => '2m',@topPack, @xfill); # !!!
951
952
## Now create and pack the title and entry
953
$eFrame->{'Label'} = $eFrame->Label->pack(@leftPack); # !!!
954
955
# $self->{"$entry"} = $eFrame->Entry(@sunken,
956
# -textvariable => \$self->{Configure}{$LabelVar})
957
# ->pack(@rightPack, @expand, @xfill);
958
959
if ($LabelType eq 'Path') #NEXT 26 ADDED 20010130 TO ADD DRIVE-LETTER SELECTION IN WINDOZE!
960
{
961
if ($Win32)
962
{
963
$_ = Win32::GetNextAvailDrive();
964
s/\W//g;
965
#my (@driveletters);
966
# @driveletters = ();
967
unless ($#driveletters >= 0)
968
{
969
for my $i ('A'..'Z')
970
{
971
last if ($i eq $_);
972
# push (@driveletters, "~$i:");
973
push (@driveletters, "$i:");
974
}
975
}
976
$driveletter ||= 'C:';
977
# $self->{"driveMenu"} = $eFrame->JOptionmenu(
978
# -textvariable => \$driveletter,
979
# -command => [\&chgDriveLetter, $self],
980
# #-relief => 'raised',
981
# #-highlightthickness => 2,
982
# -indicatoron => 0,
983
# -takefocus => 1,
984
# -options => \@driveletters)
985
# ->pack(@rightPack);
986
$self->{"driveMenu"} = $eFrame->JBrowseEntry(
987
-textvariable => \$driveletter,
988
-state => 'normal',
989
-browsecmd => [\&chgDriveLetter, $self],
990
#-highlightthickness => 2,
991
#-altbinding => 'Down=Popup,Return=Next',
992
-takefocus => 1,
993
-browse => 1,
994
-choices => \@driveletters)
995
->pack(@leftPack);
996
}
997
else
998
{
999
$driveletter = '';
1000
}
1001
}
1002
$self->{"$entry"} = $eFrame->Entry(@sunken,
1003
-textvariable => \$self->{Configure}{$LabelVar})
1004
->pack(@leftPack, @expand, @xfill);
1005
if ($LabelType eq 'File' && (!defined($self->{Configure}{-SelDir}) || $self->{Configure}{-SelDir} != 1))
1006
{
1007
$self->{"$entry"}->bind("",sub
1008
{
1009
#&RescanFiles($self);
1010
$self->{'OK'}->Invoke;
1011
});
1012
}
1013
#elsif ($LabelType eq 'Path' && $self->{Configure}{-SelDir})
1014
elsif ($LabelType eq 'Path')
1015
{
1016
if ($self->{Configure}{-SortButton})
1017
{
1018
$self->{'SortxButton'} = $eFrame->Checkbutton( -variable => \$self->{Configure}{-SortOrder},
1019
-onvalue => 'Date', -offvalue => 'Name',
1020
-text => 'Atime',
1021
-command => sub { &SortFiles($self);})
1022
->pack(@leftPack);
1023
}
1024
$self->{"$entry"}->bind("",sub
1025
{
1026
&RescanFiles($self);
1027
$self->{"$entry"}->SetCursor('end'); ###
1028
#$self->{'OK'}->focus;
1029
}
1030
);
1031
}
1032
$self->{"$entry"}->bind("",sub {$self->{'Can'}->Invoke;});
1033
1034
my ($whichlist) = 'FileList';
1035
$whichlist = 'DirList' if ($LabelType eq 'Path');
1036
1037
$self->{"$entry"}->bind("",sub
1038
{
1039
my ($oldval,$currentval);
1040
$currentval = $self->{"$entry"}->get;
1041
if (length($currentval)) #ADDED 20010131
1042
{
1043
$oldval = $currentval;
1044
$currentval = '' unless ($currentval =~ m#\/#o);
1045
$currentval =~ s#(.*\/)(.*)$#$1#;
1046
($_ = $self->{$whichlist}->get('active')) =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o;
1047
my ($restofsel) = $currentval;
1048
if ($_ && $_ ne '.' && $_ ne '..' && $_ ne '/') #IF ADDED 20010131.
1049
{
1050
($_ = $self->{$whichlist}->get('active')) =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o;
1051
$restofsel .= $_;
1052
}
1053
# elsif ($_ eq '..' && $restofsel ne $oldval)
1054
# {
1055
# $restofsel =~ s!(.*/)[^/]*/\.\./?$!$1!;
1056
# }
1057
$self->{$entry}->delete('0.0','end');
1058
$self->{$entry}->insert('end',$restofsel);
1059
Tk->break unless ($restofsel eq $oldval);
1060
}
1061
});
1062
$self->{"$entry"}->bind("",sub
1063
{
1064
my ($currentval);
1065
$currentval = $self->{"$entry"}->get;
1066
$currentval = '' unless ($currentval =~ m#\/#);
1067
$currentval =~ s#(.*\/)(.*)$#$1#;
1068
$self->{$whichlist}->UpDown(-1);
1069
my ($restofsel) = $currentval;
1070
($_ = $self->{$whichlist}->get('active')) =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o;
1071
$restofsel .= $_;
1072
$self->{$entry}->delete('0.0','end');
1073
$self->{$entry}->insert('end',$restofsel);
1074
Tk->break;
1075
}
1076
);
1077
$self->{"$entry"}->bind("",sub
1078
{
1079
my ($currentval);
1080
$currentval = $self->{"$entry"}->get;
1081
$currentval = '' unless ($currentval =~ m#\/#);
1082
$currentval =~ s#(.*\/)(.*)$#$1#;
1083
$self->{$whichlist}->UpDown(1);
1084
my ($restofsel) = $currentval;
1085
($_ = $self->{$whichlist}->get('active')) =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o;
1086
$restofsel .= $_;
1087
$self->{$entry}->delete('0.0','end');
1088
$self->{$entry}->insert('end',$restofsel);
1089
Tk->break;
1090
}
1091
);
1092
1093
return $eFrame;
1094
}
1095
1096
sub BuildBrowse
1097
{
1098
### Build the entry, label, and frame indicated. This is a
1099
### convenience routine to avoid duplication of code between
1100
### the file and the path entry widgets
1101
my($self, $LabelVar, $entry) = @_;
1102
my($LabelType) = $LabelVar;
1103
$LabelVar = "-$LabelVar";
1104
1105
## Create the entry frame
1106
my $eFrame = $self->Frame(@raised)
1107
->pack(-padx => '4m', -ipady => '2m',@topPack, @xfill); # !!!
1108
1109
## Now create and pack the title and entry
1110
$eFrame->{'Label'} = $eFrame->Label->pack(@leftPack); # !!!
1111
1112
push (@{$self->{Configure}{HistList}}, '');
1113
if ($self->{Configure}{-HistFile} && open(TEMP, $self->{Configure}{-HistFile}))
1114
{
1115
while ()
1116
{
1117
chomp;
1118
push (@{$self->{Configure}{HistList}}, $_) if ($_);
1119
}
1120
}
1121
1122
if ($LabelVar eq '-Hist')
1123
{
1124
$self->{"histToggleVal"} = (defined($self->{Configure}{-HistUsePathButton}) && $self->{Configure}{-HistUsePathButton} == 1) ? 1 : 0;
1125
if ($self->{Configure}{-HistUsePath} && $self->{Configure}{-HistUsePath} != 1)
1126
{
1127
my $pathLabel = $self->{Configure}{-HistUsePath};
1128
$pathLabel = 'Keep Path' if ($self->{Configure}{-HistUsePath} =~ /^\-?\d/);
1129
$self->{"histToggle"} = $eFrame->Checkbutton(
1130
-text => $pathLabel,
1131
-variable=> \$self->{"histToggleVal"}
1132
)->pack(@rightPack);
1133
}
1134
}
1135
$self->{"$entry"} = $eFrame->JBrowseEntry(@raised,
1136
-label => '',
1137
-state => 'readonly',
1138
-variable => \$self->{Configure}{$LabelVar},
1139
-choices => \@{$self->{Configure}{HistList}},
1140
-deleteitemsok => $self->{Configure}{-HistDeleteOk}||0,
1141
-browsecmd => sub {
1142
$self->{'OK'}->invoke unless (!$self->{Configure}{-QuickSelect} or $_[2] =~ /space$/);
1143
$self->{'FileEntry'}->delete('0.0','end');
1144
$self->{'FileEntry'}->insert('end', $self->{Configure}{$LabelVar});
1145
$self->{'FileEntry'}->focus;
1146
if ($self->{Configure}{-HistUsePath} == 1 || ($self->{Configure}{-HistUsePath} && $self->{"histToggleVal"}))
1147
{
1148
$self->{Configure}{-Path} = $self->{Configure}{$LabelVar};
1149
$self->{Configure}{-Path} =~ s#\/[^\/]+$## unless (-d $self->{Configure}{-Path});
1150
$driveletter = $1 if ($^O =~ /Win/i && $self->{Configure}{-Path} =~ s/^(\w\:)//);
1151
&RescanFiles($self);
1152
}
1153
$self->{Configure}{$LabelVar} = '';
1154
},
1155
-listrelief => 'flat')
1156
->pack(@rightPack, @expand, @xfill);
1157
1158
$eFrame->packForget unless ($self->{Configure}{-HistFile});
1159
#DOESN'T WORK?! $self->{"$entry"}->bind('', sub {
1160
# $self->{'FileEntry'}->delete('0.0','end');
1161
# $self->{'FileEntry'}->insert('end',\$self->{Configure}{$LabelVar});
1162
# Tk->break;
1163
# });
1164
1165
return $eFrame;
1166
}
1167
1168
sub BuildFAV
1169
{
1170
### Build the entry, label, and frame indicated. This is a
1171
### convenience routine to avoid duplication of code between
1172
### the file and the path entry widgets
1173
my($self, $LabelVar, $entry) = @_;
1174
my($LabelType) = $LabelVar;
1175
$LabelVar = "-$LabelVar";
1176
1177
## Create the entry frame
1178
my $eFrame = $self->Frame(@raised)
1179
->pack(-padx => '4m', -ipady => '2m',@topPack, @xfill); # !!!
1180
1181
## Now create and pack the title and entry
1182
$eFrame->{'Label'} = $eFrame->Label->pack(@leftPack); # !!!
1183
1184
${$self->{Configure}{PathList}}{''} = '';
1185
my ($l, $r, $s, $dir);
1186
if ($Win32 && -d $self->{Configure}{-PathFile}) #ADDED 20081029 TO ALLOW USAGE OF WINDOWS' "FAVORITES" (v1.4)
1187
{
1188
(my $pathDir = $self->{Configure}{-PathFile}) =~ s#\\#\/#go;
1189
chop($pathDir) if ($pathDir =~ m#\/$#);
1190
my ($f, %favHash);
1191
if (opendir (FAVDIR, $pathDir))
1192
{
1193
while (defined($f = readdir(FAVDIR)))
1194
{
1195
if ($f =~ /\.lnk$/o)
1196
{
1197
# print "-file=$f=\n";
1198
if (open (LNKFILE, "<${pathDir}/$f"))
1199
{
1200
while (defined($s = ))
1201
{
1202
if ($s =~ /(\w\:\\\w[\w\\\_\-\. ]+)/o)
1203
{
1204
($dir = $1) =~ s#\\#\/#gso;
1205
$dir =~ s/\s+#//gso;
1206
if (-d $dir)
1207
{
1208
$f =~ s/\.lnk//io;
1209
$favHash{$f} = $dir;
1210
last;
1211
}
1212
}
1213
}
1214
close LNKFILE;
1215
}
1216
}
1217
}
1218
closedir FAVDIR;
1219
foreach $f (sort keys %favHash)
1220
{
1221
${$self->{Configure}{PathList}}{$favHash{$f}} = $f;
1222
}
1223
}
1224
}
1225
elsif ($self->{Configure}{-PathFile} && open(TEMP, $self->{Configure}{-PathFile}))
1226
{
1227
while ()
1228
{
1229
chomp;
1230
if ($_)
1231
{
1232
$l = $_;
1233
$r = '';
1234
($l,$r) = split(/\;/o);
1235
$r ||= $l;
1236
${$self->{Configure}{PathList}}{$l} = $r;
1237
}
1238
}
1239
}
1240
1241
$self->{"$entry"} = $eFrame->JBrowseEntry(@raised,
1242
-label => '',
1243
-state => 'readonly',
1244
-variable => \$self->{Configure}{$LabelVar},
1245
-choices => \%{$self->{Configure}{PathList}},
1246
-browsecmd => sub {
1247
$self->{Configure}{-Path} = $self->{$entry}->dereference($self->{Configure}{$LabelVar});
1248
&RescanFiles($self) unless (!$self->{Configure}{-QuickSelect} or $_[2] =~ /space$/);
1249
$self->{'FileEntry'}->focus;
1250
},
1251
-listrelief => 'flat')
1252
->pack(@rightPack, @expand, @xfill);
1253
$eFrame->packForget unless ($self->{Configure}{-PathFile} && -r $self->{Configure}{-PathFile});
1254
return $eFrame;
1255
}
1256
1257
sub BuildListBoxes
1258
{
1259
my($self) = shift;
1260
1261
## Destroy both, if they're there
1262
if ($self->{'DFFrame'} && $self->{'DFFrame'}->IsWidget)
1263
{
1264
$self->{'DFFrame'}->destroy;
1265
}
1266
1267
$self->{'DFFrame'} = $self->Frame;
1268
$self->{'DFFrame'}->pack(-before => $self->{'FEF'},
1269
@topPack, @bothFill, @expand);
1270
1271
## Build the file window before the directory window, even
1272
## though the file window is below the directory window, we'll
1273
## pack the directory window before.
1274
&BuildListBox($self, 'FileFrame',
1275
$self->{Configure}{-FileLBCaption},
1276
'FileList','right','bottom');
1277
## Set up the bindings for the file list
1278
&BindFile($self);
1279
1280
if ($self->{Configure}{-Chdir})
1281
{
1282
&BuildListBox($self,'DirFrame',$self->{Configure}{-DirLBCaption},
1283
'DirList','left','top');
1284
&BindDir($self);
1285
}
1286
}
1287
1288
sub BuildFDWindow
1289
{
1290
### Build the entire file dialog window
1291
my($self) = shift;
1292
### Build the filename entry box
1293
$self->{'FEF'} = &BuildEntry($self, 'File', 'FileEntry');
1294
1295
### Build the pathname directory box
1296
$self->{'PEF'} = &BuildEntry($self, 'Path','DirEntry');
1297
1298
### JWT:Build the History Dropdown list.
1299
$self->{'HEF'} = &BuildBrowse($self, 'Hist', 'HistEntry');
1300
1301
### Now comes the multi-part frame
1302
my $patFrame = $self->Frame->pack(-padx => '4m', -pady => '2m', @topPack, @xfill); # !!!
1303
1304
## Label first...
1305
$self->{'patFrame'}->{'Label'} = $patFrame->Label->pack(@leftPack); # !!!
1306
1307
## Now the entry...
1308
$self->{'FPat'} = $patFrame->Entry(-textvariable => \$self->{Configure}{-FPat})
1309
->pack(@leftPack, @expand, @xfill);
1310
$self->{'FPat'}->bind("",sub { &RescanFiles($self);});
1311
1312
## and the radio box
1313
$self->{'SABox'} = $patFrame->Checkbutton(-variable => \$self->{Configure}{-ShowAll},
1314
-command => sub { &RescanFiles($self);})
1315
->pack(@leftPack);
1316
1317
### JWT:Build the Favorites Dropdown list.
1318
$self->{'FAV'} = &BuildFAV($self, 'FAV', 'FavEntry');
1319
1320
### FINALLY!!! the button frame
1321
my $butFrame = $self->Frame(@raised);
1322
$butFrame->pack(-padx => '2m', -pady => '2m', @topPack, @xfill);
1323
1324
$self->{'OK'} = $butFrame->Button(-command => sub
1325
{
1326
&GetReturn($self);
1327
}
1328
)
1329
->pack(-padx => '2m', -pady => '2m', @leftPack, @expand, @xfill);
1330
1331
$self->{'Rescan'} = $butFrame->Button(-command => sub
1332
{
1333
&RescanFiles($self);
1334
}
1335
)
1336
->pack(-padx => '2m', -pady => '2m', @leftPack, @expand, @xfill);
1337
1338
$self->{'Can'} = $butFrame->Button(-command => sub
1339
{
1340
$self->{'Retval'} = -1;
1341
}
1342
)->pack(-padx => '2m', -pady => '2m', @leftPack, @expand, @xfill);
1343
1344
$self->{'Home'} = $butFrame->Button(
1345
-text => 'Home',
1346
-underline => 0,
1347
-command => sub
1348
{
1349
$self->{Configure}{-Path} = $ENV{HOME} || $ENV{LOGDIR};
1350
$self->{Configure}{-Path} =~ s#\\#\/#go;
1351
$self->{Configure}{-Path} = (getpwuid($<))[7]
1352
unless ($Win32 || !$< || $self->{Configure}{-Path});
1353
$self->{Configure}{-Path} ||= &cwd() || &getcwd();
1354
&RescanFiles($self);
1355
}
1356
)->pack(-padx => '2m', -pady => '2m', @leftPack, @expand, @xfill);
1357
1358
$self->{'Current'} = $butFrame->Button(
1359
-text => 'CWD',
1360
-underline => 1,
1361
-command => sub
1362
{
1363
$self->{Configure}{-Path} = &cwd() || &getcwd();
1364
$self->{Configure}{-Path} =~ s#\\#\/#go;
1365
&RescanFiles($self);
1366
}
1367
)->pack(-padx => '2m', -pady => '2m', @leftPack, @expand, @xfill);
1368
1369
if (-e "$ENV{HOME}/.cdout")
1370
{
1371
my $cdir0 = &cwd() || &getcwd();
1372
my $cdir = $cdir0;
1373
open (CD, "$ENV{HOME}/.cdout") || last;
1374
$cdir = ;
1375
chomp($cdir);
1376
close CD;
1377
if ($cdir ne $cdir0) {
1378
$self->{'CDOUT'} = $butFrame->Button(
1379
-text => 'Cdir',
1380
-underline => 1,
1381
-command => sub
1382
{
1383
$self->{Configure}{-Path} = $cdir;
1384
$self->{Configure}{-Path} =~ s#\\#\/#go;
1385
&RescanFiles($self);
1386
}
1387
)->pack(-padx => '2m', -pady => '2m', @leftPack, @expand, @xfill);
1388
}
1389
}
1390
}
1391
1392
sub RescanFiles
1393
{
1394
### Fill the file and directory boxes
1395
my($self) = shift;
1396
1397
my($fl) = $self->{'FileList'};
1398
my($dl) = $self->{'DirList'};
1399
my($path) = $self->{Configure}{-Path};
1400
my($show) = $self->{Configure}{-ShowAll};
1401
my($chdir) = $self->{Configure}{-Chdir};
1402
### Remove a final / if it is there, and add it
1403
$path = '' unless (defined($path));
1404
$_ = &cwd() || &getcwd();
1405
if ($path !~ /\S/)
1406
{
1407
$self->{Configure}{-Path} = $path if ($path eq '/');
1408
}
1409
$path =~ s/^\./$_/;
1410
$driveletter = $1 if ($path =~ s/^(\w\:)(.*)$/$2/);
1411
$driveletter =~ tr/a-z/A-Z/;
1412
$path =~ s!(.*/)[^/]*/\.\./?$!$1!
1413
&& $self->{Configure}{-Path} =~ s!(.*/)[^/]*/\.\./?$!$1!;
1414
if ($^O =~ /Win/i)
1415
{
1416
if (length($path) && substr($path,-1,1) ne '/')
1417
{
1418
$path .= '/';
1419
}
1420
$self->{Configure}{-Path} = $path;
1421
$path = $driveletter . $path if ($driveletter);
1422
#$path =~ s!^/([a-zA-Z]\:)!$1!;
1423
}
1424
else
1425
{
1426
if ($path =~ /^~/o)
1427
{
1428
$path = `ls -d $path`; # !!! HANDLES DIRS W/ A TILDE!
1429
chomp($path);
1430
}
1431
if ((length($path) == 0) || (substr($path,-1,1) ne '/'))
1432
{
1433
$path .= '/';
1434
$self->{Configure}{-Path} = $path;
1435
}
1436
}
1437
### path now has a trailing / no matter what
1438
1439
unless (($path =~ /^~/o) || -d $path)
1440
{
1441
print STDERR "-JFileDialog: =$path= is NOT a directory\n";
1442
carp "$path is NOT a directory\n";
1443
return 0;
1444
}
1445
1446
$self->configure(-cursor => 'watch');
1447
my($OldGrab) = $self->grab('current');
1448
$self->{'Rescan'}->grab;
1449
$self->{'Rescan'}->configure(-state => 'disabled');
1450
$self->update;
1451
my (@allfiles);
1452
if (opendir(ALLFILES,$path))
1453
{
1454
@allfiles = readdir(ALLFILES);
1455
closedir(ALLFILES);
1456
}
1457
my($direntry);
1458
1459
## First, get the directories...
1460
if ($chdir)
1461
{
1462
my ($parentfound) = 0;
1463
$dl->delete(0,'end');
1464
$dl->insert('end', '/') unless ($path eq '/');
1465
foreach $direntry (sort @allfiles)
1466
{
1467
next if !-d "$path$direntry";
1468
next if $direntry eq ".";
1469
if ( !$show
1470
&& (substr($direntry,0,1) eq ".")
1471
&& $direntry ne "..")
1472
{
1473
next;
1474
}
1475
next if ($direntry eq '..' && $path eq '/');
1476
$dl->insert('end',$direntry);
1477
$parentfound = 1 if ($direntry =~ /^\.\./o);
1478
}
1479
$dl->insert(1,'..') #ADDED 20010130 JWT TO FIX MISSING ".." CHOICE!
1480
unless ($parentfound || $path eq '/' || ($path =~ m#^\w\:\/?$#o));
1481
$dl->insert(1,'.') if ($path eq '/' || ($path =~ m#^\w\:\/?$#o));
1482
}
1483
1484
## Now, get the files
1485
$fl->delete(0,'end');
1486
1487
$_ = $self->{Configure}{-FPat};
1488
s/^\s*|\s*$//;
1489
$_ = $self->{Configure}{-FPat} = '*' if $_ eq '';
1490
1491
my($pat) = $_;
1492
undef @allfiles;
1493
1494
@allfiles = <$path.$pat> if $show;
1495
1496
my ($cmd) = $path . $pat;
1497
if (opendir(DIR, $path))
1498
{
1499
@allfiles = grep { /\.${pat}$/i } readdir(DIR);
1500
closedir DIR;
1501
}
1502
if ($self->{Configure}{-SortOrder} =~ /^N/o)
1503
{
1504
foreach $direntry (sort @allfiles)
1505
{
1506
if (-f "${path}$direntry")
1507
{
1508
$direntry =~ s!.*/([^/]*)$!$1!;
1509
next if (!$show && $direntry =~ /^\./o); #SKIP ".-FILES" EVEN ON WINDOWS!
1510
$fl->insert('end',$direntry);
1511
}
1512
}
1513
}
1514
else
1515
{
1516
1517
my @sortedFiles;
1518
foreach $direntry (@allfiles)
1519
{
1520
if (-f "${path}$direntry")
1521
{
1522
my (@timestuff, @stats, $atime);
1523
@stats = stat "${path}$direntry";
1524
@timestuff = localtime($stats[9]);
1525
$atime = ($timestuff[5] + 1900);
1526
$atime .= '0' if ($timestuff[4] < 9);
1527
$atime .= ($timestuff[4] + 1);
1528
$atime .= '0' if ($timestuff[3] < 10);
1529
$atime .= $timestuff[3];
1530
$atime .= ' ';
1531
$atime .= '0' if ($timestuff[2] < 10);
1532
$atime .= $timestuff[2];
1533
$atime .= '0' if ($timestuff[1] < 10);
1534
$atime .= $timestuff[1];
1535
$direntry =~ s!.*/([^/]*)$!$1!;
1536
next if (!$show && $direntry =~ /^\./o); #SKIP ".-FILES" EVEN ON WINDOWS!
1537
push @sortedFiles, ($atime . ' ' . $direntry);
1538
}
1539
}
1540
my @stats;
1541
foreach $direntry (sort @sortedFiles)
1542
{
1543
$fl->insert('end',$direntry);
1544
}
1545
}
1546
1547
$self->configure(-cursor => 'top_left_arrow');
1548
1549
if ($^O =~ /Win/i)
1550
{
1551
my $foundit = 0;
1552
for (my $i=0;$i<=$#driveletters;$i++)
1553
{
1554
if ($driveletters[$i] eq $driveletter)
1555
{
1556
$foundit = 1;
1557
last;
1558
}
1559
}
1560
unless ($foundit)
1561
{
1562
my @l = @driveletters;
1563
push (@l, $driveletter);
1564
@driveletters = sort @l;
1565
$self->{"driveMenu"}->choices(\@driveletters);
1566
}
1567
1568
}
1569
$self->{'Rescan'}->grab('release') if $self->grab('current') == $self->{'Rescan'};
1570
$OldGrab->grab if defined($OldGrab);
1571
$self->{'Rescan'}->configure(-state => 'normal');
1572
$self->update;
1573
return 1;
1574
}
1575
1576
sub add2Hist
1577
{
1578
my $self = shift;
1579
my $fname = shift;
1580
1581
if ($self->{Configure}{HistList} && $self->{Configure}{-HistFile}
1582
&& open(TEMP, ">$self->{Configure}{-HistFile}"))
1583
{
1584
shift (@{$self->{Configure}{HistList}});
1585
print TEMP "$fname\n";
1586
my $i = 1;
1587
my $t;
1588
while (@{$self->{Configure}{HistList}})
1589
{
1590
$t = shift(@{$self->{Configure}{HistList}});
1591
unless ($t eq $fname)
1592
{
1593
print TEMP "$t\n";
1594
++$i;
1595
last if ($self->{Configure}{-History}
1596
&& $i >= $self->{Configure}{-History});
1597
}
1598
}
1599
close TEMP;
1600
if ($self->{Configure}{-HistUsePath} == 1 || ($self->{Configure}{-HistUsePath} && $self->{"histToggleVal"}))
1601
{
1602
#$fname = 'v:/dev/.propval/html/x.pl';
1603
$self->{Configure}{-Path} = $fname;
1604
$self->{Configure}{-Path} =~ s#\/[^\/]+$## unless (-d $self->{Configure}{-Path});
1605
$driveletter = $1 if ($^O =~ /Win/i && $self->{Configure}{-Path} =~ s/^(\w\:)//);
1606
#"=".$fname."=".$driveletter."=".$xxx."="
1607
}
1608
}
1609
}
1610
1611
sub GetReturn
1612
{
1613
my ($self) = @_;
1614
1615
## Construct the filename
1616
my $path = $self->{Configure}{-Path};
1617
my $fname;
1618
if ($self->{Configure}{-Hist})
1619
{
1620
$fname = $self->{Configure}{-Hist};
1621
@{$self->{Configure}{HistList}} = $self->{HistEntry}->choices();
1622
&add2Hist($self, $fname);
1623
}
1624
elsif ($^O =~ /Win/i)
1625
{
1626
$path = $driveletter . $path if ($driveletter);
1627
$path .= "/" if (substr($path, -1, 1) ne '/');
1628
$path .= "/" if (length($path) && substr($path, -1, 1) ne '/');
1629
1630
if ($self->{Configure}{-SelDir})
1631
{
1632
$fname = $self->{'DirList'};
1633
if (defined($fname->curselection))
1634
{
1635
$fname = $fname->get($fname->curselection);
1636
$fname =~ s/^\d\d\d\d\d\d\d\d \d\d \d\d//o;
1637
if ($fname =~ /^\.\.$/) # !!!
1638
{
1639
$path =~ s/\/$//;
1640
$path =~ s#/[^/]*$#/#;
1641
}
1642
}
1643
else
1644
{
1645
$fname = '';
1646
}
1647
if ($fname =~ /^\.\.$/)
1648
{
1649
$fname = $path;
1650
$fname = '/' if ($fname le ' ');
1651
}
1652
else
1653
{
1654
$fname = $path . $fname;
1655
}
1656
$fname =~ s/\/$// unless ($fname =~ /^\/$/);
1657
}
1658
if ($self->{Configure}{-SelDir} != 1)
1659
{
1660
if (!$self->{Configure}{-SelDir} && $self->{Configure}{-File} le ' ')
1661
{
1662
$self->{'RetFile'} = undef;
1663
$self->{'Retval'} = -1;
1664
return;
1665
}
1666
elsif (substr($self->{Configure}{-File},0,1) eq '/') # !!!
1667
{
1668
$fname = $self->{Configure}{-File}; #!!!
1669
}
1670
elsif ($self->{Configure}{-SelDir} != 2 || $self->{Configure}{-File} gt ' ')
1671
{
1672
#WINNT: $fname = $path . $self->{Configure}{-File};
1673
$fname = $path unless ($self->{Configure}{-File} =~ /^[a-zA-Z]\:/);
1674
$fname .= $self->{Configure}{-File};
1675
}
1676
## Make sure that the file exists, if the user is not allowed
1677
## to create
1678
if (!$self->{Configure}{-Create} && $self->{Configure}{-File} gt ' ' && !(-f $fname) && !((-d $fname) && $self->{Configure}{-SelDir}))
1679
{
1680
## Put up no create dialog
1681
my($path) = $self->{Configure}{-Path};
1682
$path = $driveletter . $path if ($driveletter);
1683
my($file) = $self->{Configure}{-File};
1684
my($filename) = $fname;
1685
eval "\$fname = \"$self->{Configure}{-EDlgText}\"";
1686
$self->JDialog(-title => $self->{Configure}{-EDlgTitle},
1687
-text => $fname,
1688
-bitmap => 'error')
1689
->Show;
1690
return;
1691
}
1692
}
1693
1694
&add2Hist($self, $fname);
1695
}
1696
else
1697
{
1698
my $fnamex;
1699
1700
if ($path =~ /^~/)
1701
{
1702
#$path = `rksh 'ls -d $path'`; # !!! HANDLES DIRS W/ A TILDE!
1703
$path = `ls -d $path`; # !!! HANDLES DIRS W/ A TILDE!
1704
chomp($path);
1705
}
1706
$path .= "/" if (substr($path, -1, 1) ne '/');
1707
if ($self->{Configure}{-SelDir})
1708
{
1709
$fname = $self->{'DirList'};
1710
if (defined($fname->curselection))
1711
{
1712
$fname = $fname->get($fname->curselection);
1713
if ($fname =~ /^\.\.$/) # !!!
1714
{
1715
$path =~ s/\/$//;
1716
$path =~ s#/[^/]*$#/#;
1717
}
1718
$fname =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o;
1719
}
1720
else
1721
{
1722
$fname = '';
1723
}
1724
if ($fname =~ /^\.\.$/)
1725
{
1726
$fname = $path;
1727
$fname = '/' if ($fname le ' ');
1728
}
1729
elsif ($fname =~ /^~/) # !!!
1730
{
1731
#$fname = `rksh 'ls -d $fname'`; # !!! HANDLES FILES W/ A TILDE!
1732
$fname = `ls -d $fname`; # !!! HANDLES FILES W/ A TILDE!
1733
chomp($fname);
1734
}
1735
else
1736
{
1737
$fname = $path . $fname;
1738
}
1739
$fname =~ s/\/$// unless ($fname =~ /^\/$/);
1740
}
1741
if ($self->{Configure}{-SelDir} != 1)
1742
{
1743
if (!$self->{Configure}{-SelDir} && $self->{Configure}{-File} le ' ')
1744
{
1745
$self->{'RetFile'} = undef;
1746
$self->{'Retval'} = -1;
1747
return;
1748
}
1749
$fnamex = $self->{Configure}{-File};
1750
if ($fnamex =~ /^~/) # !!!
1751
{
1752
#$fnamex = `rksh 'ls -d $fnamex'`; # !!! HANDLES FILES W/ A TILDE!
1753
$fnamex = `ls -d $fnamex`;
1754
chomp($fnamex);
1755
$fname = $fnamex;
1756
}
1757
elsif (substr($fnamex,0,1) eq '/') # !!!
1758
{
1759
$fname = $fnamex; #!!!
1760
}
1761
elsif ($self->{Configure}{-SelDir} != 2 || $self->{Configure}{-File} gt ' ')
1762
{
1763
#$fname = $path . $self->{Configure}{-File}; #CHGD. TO NEXT 20050417 PER PATCH FROM Paul Falbe.
1764
($fname = $path . $self->{Configure}{-File}) =~ s/,/,$path/g;
1765
}
1766
## Make sure that the file exists, if the user is not allowed
1767
## to create
1768
if (!$self->{Configure}{-Create} && $self->{Configure}{-File} gt ' ' && !(-f $fname) && !((-d $fname) && $self->{Configure}{-SelDir}))
1769
{
1770
## Put up no create dialog
1771
my($path) = $self->{Configure}{-Path};
1772
$path = $driveletter . $path if ($driveletter);
1773
my($file) = $self->{Configure}{-File};
1774
my($filename) = $fname;
1775
eval "\$fname = \"$self->{Configure}{-EDlgText}\"";
1776
$self->JDialog(-title => $self->{Configure}{-EDlgTitle},
1777
-text => $fname,
1778
-bitmap => 'error')
1779
->Show;
1780
## And return
1781
return;
1782
}
1783
}
1784
&add2Hist($self, $fname);
1785
}
1786
$self->{'RetFile'} = $fname;
1787
$self->{'Retval'} = 1;
1788
}
1789
1790
sub keyFn #JWT: TRAP LETTERS PRESSED AND ADJUST SELECTION ACCORDINGLY.
1791
{
1792
my ($e,$w,$l) = @_;
1793
my $mykey = $e->XEvent->A;
1794
# if ($w->cget( "-state" ) eq "readonly") #TEXT FIELD HAS FOCUS.
1795
# {
1796
if ($mykey)
1797
{
1798
my ($entryval) = $e->get;
1799
$entryval =~ s#(.*/)(.*)$#$2#;
1800
&LbFindSelection($l,$entryval);
1801
}
1802
# }
1803
# else #LISTBOX HAS FOCUS.
1804
# {
1805
# &LbFindSelection($w) if ($mykey);
1806
# }
1807
}
1808
1809
sub LbFindSelection
1810
{
1811
my ($l, $var_ref, $srchval) = @_;
1812
1813
#my $var_ref;
1814
1815
unless ($srchval)
1816
{
1817
#my $var_ref = $w->cget( "-textvariable" );
1818
#my $var_ref = \$w->{Configure}{$LabelVar};
1819
$srchval = $var_ref;
1820
}
1821
#my $l = $w;
1822
#$l->configure(-selectmode => 'browse'); #CHGD. TO NEXT. 20050418 TO ALLOW MULTIPLE SELECTIONS.
1823
$l->configure(-selectmode => 'browse')
1824
if ($l->{Configure}{-selectmode} eq 'single');
1825
my (@listsels) = $l->get('0','end');
1826
if ($#listsels >= 0 && $listsels[0] =~ /^\d\d\d\d\d\d\d\d \d\d\d\d /)
1827
{
1828
foreach my $i (0..$#listsels)
1829
{
1830
$listsels[$i] =~ s/^\d\d\d\d\d\d\d\d \d\d\d\d //o;
1831
}
1832
}
1833
foreach my $i (0..$#listsels)
1834
{
1835
if ($listsels[$i] eq $srchval)
1836
{
1837
$l->selectionClear('0','end');
1838
$l->activate($i);
1839
$l->selectionSet($i);
1840
$l->see($i);
1841
#my $var_ref = $w->cget("-listok") || undef;;
1842
#$$var_ref = 1 if (defined($var_ref));
1843
return $i;
1844
}
1845
}
1846
foreach my $i (0..$#listsels)
1847
{
1848
if ($listsels[$i] =~ /^$srchval/)
1849
{
1850
$l->selectionClear('0','end');
1851
$l->activate($i);
1852
$l->selectionSet($i);
1853
$l->see($i);
1854
#$var_ref = $w->cget("-listok") || undef;;
1855
#$$var_ref = 1 if (defined($var_ref));
1856
return $i;
1857
}
1858
}
1859
foreach my $i (0..$#listsels)
1860
{
1861
if ($listsels[$i] =~ /^$srchval/i)
1862
{
1863
$l->selectionClear('0','end');
1864
$l->activate($i);
1865
$l->selectionSet($i);
1866
$l->see($i);
1867
#$var_ref = $w->cget("-listok") || undef;;
1868
#$$var_ref = 1 if (defined($var_ref));
1869
return $i;
1870
}
1871
}
1872
#$var_ref = $w->cget("-listok") || undef;;
1873
#$$var_ref = 0 if (defined($var_ref));
1874
return -1;
1875
}
1876
1877
sub chgDriveLetter #ADDED 20010130 BY JWT.
1878
{
1879
my ($self) = shift;
1880
1881
#$_ = $self->{Configure}{-Path};
1882
#s!^\w\:!$driveletter! if ($driveletter =~ /\w\:/);
1883
#$self->{Configure}{-Path} = $driveletter if ($driveletter =~ /\w\:/);
1884
$driveletter =~ tr/a-z/A-Z/;
1885
$driveletter = substr($driveletter,0,1) . ':' if (length($driveletter) >= 2 || $driveletter =~ /^[A-Z]$/);
1886
$self->{Configure}{-Path} = '' if ($_[2] =~ /(?:listbox|key\.\w)/);
1887
$self->{Configure}{-Path} = &cwd() || &getcwd()
1888
if (!$self->{Configure}{-Path} && $driveletter =~ /$cwdDfltDrive/i);
1889
&RescanFiles($self);
1890
}
1891
1892
sub SortFiles
1893
{
1894
my ($self) = shift;
1895
1896
&RescanFiles($self);
1897
}
1898
1899
### Return 1 to the calling use statement ###
1900
1;
1901
### End of file FileDialog.pm ###
1902
__END__