home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _c3ff7e99ec0c01b56a009e03c63c7f20 < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.2 KB  |  107 lines
  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.              _removeCachedFileDialogs();
  42.              })->pack(-side => 'left');
  43.     my $fdb = $cbf->Radiobutton
  44.       (-text => 'FBox',
  45.        -variable => \$fd,
  46.        -value => 'FBox',
  47.        -command => sub { local($^W) = 0;
  48.              require Tk::FBox;
  49.              Tk::FBox->import('as_default');
  50.              _removeCachedFileDialogs();
  51.              })->pack(-side => 'left');
  52.     $fdb->invoke;
  53.  
  54. # XXX Motif style file box not implemented
  55. #     unless (compare($tcl_platform{'platform'},'unix'))
  56. #       {
  57. #       $w->{'.strict'} = $w->Checkbutton('Name','strict','-text',"Use Motif Style Dialog",'-variable','tk_strictMotif','-onvalue',1,'-offvalue',0);
  58. #       $w->{'.strict'}->pack('-anchor','c');
  59. #       }
  60. }
  61.  
  62. sub fileDialog {
  63.     my $w = shift;
  64.     my $ent = shift;
  65.     my $operation = shift;
  66.     my $types;
  67.     my $file;
  68.     #   Type names        Extension(s)    Mac File Type(s)
  69.     #
  70.     #---------------------------------------------------------
  71.     @types =
  72.       (["Text files",           [qw/.txt .doc/]],
  73.        ["Text files",           '',             'TEXT'],
  74.        ["Perl Scripts",         '.pl',        'TEXT'],
  75.        ["C Source Files",    ['.c', '.h']],
  76.        ["All Source Files",     [qw/.tcl .c .h/]],
  77.        ["Image Files",        '.gif'],
  78.        ["Image Files",        ['.jpeg', '.jpg']],
  79.        ["Image Files",       '',        [qw/GIFF JPEG/]],
  80.        ["All files",        '*']
  81.       );
  82.     if ($operation eq 'open') {
  83.     $file = $w->getOpenFile(-filetypes => \@types);
  84.     } else {
  85.     $file = $w->getSaveFile(-filetypes => \@types,
  86.                 -initialfile => 'Untitled',
  87.                 -defaultextension => '.txt');
  88.     }
  89.     if (defined $file and $file ne '') {
  90.     $ent->delete(0, 'end');
  91.     $ent->insert(0, $file);
  92.     $ent->xview('end');
  93.     }
  94. }
  95.  
  96. sub _removeCachedFileDialogs {
  97.     my $mw = $TOP->MainWindow;
  98.     my $remove = sub {
  99.     my $t = shift;
  100.     return if (!UNIVERSAL::isa($t, "Tk::Toplevel"));
  101.     delete $t->{'tk_getOpenFile'};
  102.     delete $t->{'tk_getSaveFile'};
  103.     };
  104.     $remove->($mw);
  105.     $mw->Walk($remove);
  106. }
  107.