projects / OpenSPARC-T2-DV / blame
| Commit | Line | Data |
|---|---|---|
| 86530b38 AT |
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 | } |