| 1 | # filebox.tcl -- |
| 2 | # |
| 3 | # This demonstration script prompts the user to select a file. |
| 4 | # |
| 5 | # SCCS: @(#) filebox.tcl 1.3 97/03/02 16:22:36 |
| 6 | |
| 7 | use vars qw/$TOP/; |
| 8 | |
| 9 | sub filebox { |
| 10 | my $demo = shift; |
| 11 | |
| 12 | $TOP = $MW->WidgetDemo |
| 13 | ( |
| 14 | -name => $demo, |
| 15 | -text => "Enter a file name in the entry box or click on the \"Browse\" buttons to select a file name using the file selection dialog.", |
| 16 | -title => 'File box Demonstration', |
| 17 | -iconname => 'filebox', |
| 18 | ); |
| 19 | foreach my $i (qw(open save)) { |
| 20 | my $f = $TOP->Frame; |
| 21 | my $lab = $f->Label(-text => "Select a file to $i: ", |
| 22 | -anchor => 'e'); |
| 23 | my $ent = $f->Entry(-width => 20); |
| 24 | my $but = $f->Button(-text => "Browse ...", |
| 25 | -command => sub { fileDialog($TOP, $ent, $i)}); |
| 26 | $lab->pack(-side => 'left'); |
| 27 | $ent->pack(-side => 'left',-expand => 'yes', -fill => 'x'); |
| 28 | $but->pack(-side => 'left'); |
| 29 | $f->pack(-fill => 'x', -padx => '1c', -pady => 3); |
| 30 | } |
| 31 | |
| 32 | my $cbf = $TOP->Frame->pack(-fill => 'x', -padx => '1c', -pady => 3); |
| 33 | my $fd; |
| 34 | $cbf->Radiobutton |
| 35 | (-text => 'FileSelect', |
| 36 | -variable => \$fd, |
| 37 | -value => 'FileSelect', |
| 38 | -command => sub { local($^W) = 0; |
| 39 | require Tk::FileSelect; |
| 40 | Tk::FileSelect->import('as_default'); |
| 41 | # XXX remove cached dialogs |
| 42 | my $mw = $TOP->MainWindow; |
| 43 | delete $mw->{'tk_getOpenFile'}; |
| 44 | delete $mw->{'tk_getSaveFile'}; |
| 45 | })->pack(-side => 'left'); |
| 46 | my $fdb = $cbf->Radiobutton |
| 47 | (-text => 'FBox', |
| 48 | -variable => \$fd, |
| 49 | -value => 'FBox', |
| 50 | -command => sub { local($^W) = 0; |
| 51 | require Tk::FBox; |
| 52 | Tk::FBox->import('as_default'); |
| 53 | # XXX remove cached dialogs |
| 54 | my $mw = $TOP->MainWindow; |
| 55 | delete $mw->{'tk_getOpenFile'}; |
| 56 | delete $mw->{'tk_getSaveFile'}; |
| 57 | })->pack(-side => 'left'); |
| 58 | $fdb->invoke; |
| 59 | |
| 60 | # XXX Motif style file box not implemented |
| 61 | # unless (compare($tcl_platform{'platform'},'unix')) |
| 62 | # { |
| 63 | # $w->{'.strict'} = $w->Checkbutton('Name','strict','-text',"Use Motif Style Dialog",'-variable','tk_strictMotif','-onvalue',1,'-offvalue',0); |
| 64 | # $w->{'.strict'}->pack('-anchor','c'); |
| 65 | # } |
| 66 | } |
| 67 | |
| 68 | sub fileDialog { |
| 69 | my $w = shift; |
| 70 | my $ent = shift; |
| 71 | my $operation = shift; |
| 72 | my $types; |
| 73 | my $file; |
| 74 | # Type names Extension(s) Mac File Type(s) |
| 75 | # |
| 76 | #--------------------------------------------------------- |
| 77 | @types = |
| 78 | (["Text files", [qw/.txt .doc/]], |
| 79 | ["Text files", '', 'TEXT'], |
| 80 | ["Perl Scripts", '.pl', 'TEXT'], |
| 81 | ["C Source Files", ['.c', '.h']], |
| 82 | ["All Source Files", [qw/.tcl .c .h/]], |
| 83 | ["Image Files", '.gif'], |
| 84 | ["Image Files", ['.jpeg', '.jpg']], |
| 85 | ["Image Files", '', [qw/GIFF JPEG/]], |
| 86 | ["All files", '*'] |
| 87 | ); |
| 88 | if ($operation eq 'open') { |
| 89 | $file = $w->getOpenFile(-filetypes => \@types); |
| 90 | } else { |
| 91 | $file = $w->getSaveFile(-filetypes => \@types, |
| 92 | -initialfile => 'Untitled', |
| 93 | -defaultextension => '.txt'); |
| 94 | } |
| 95 | if (defined $file and $file ne '') { |
| 96 | $ent->delete(0, 'end'); |
| 97 | $ent->insert(0, $file); |
| 98 | $ent->xview('end'); |
| 99 | } |
| 100 | } |