home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _5643a3869a531863dfd279b8b7eaa19c < prev    next >
Encoding:
Text File  |  2002-05-30  |  25.5 KB  |  891 lines
  1. # -*- perl -*-
  2. #
  3. # tkfbox.tcl --
  4. #
  5. #       Implements the "TK" standard file selection dialog box. This
  6. #       dialog box is used on the Unix platforms whenever the tk_strictMotif
  7. #       flag is not set.
  8. #
  9. #       The "TK" standard file selection dialog box is similar to the
  10. #       file selection dialog box on Win95(TM). The user can navigate
  11. #       the directories by clicking on the folder icons or by
  12. #       selecting the "Directory" option menu. The user can select
  13. #       files by clicking on the file icons or by entering a filename
  14. #       in the "Filename:" entry.
  15. #
  16. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  17. #
  18. # See the file "license.terms" for information on usage and redistribution
  19. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  20. #
  21. # Translated to perk/Tk by Slaven Rezic <eserte@cs.tu-berlin.de>.
  22. #
  23.  
  24. #----------------------------------------------------------------------
  25. #
  26. #              F I L E   D I A L O G
  27. #
  28. #----------------------------------------------------------------------
  29. # tkFDialog --
  30. #
  31. #    Implements the TK file selection dialog. This dialog is used when
  32. #    the tk_strictMotif flag is set to false. This procedure shouldn't
  33. #    be called directly. Call tk_getOpenFile or tk_getSaveFile instead.
  34. #
  35.  
  36. package Tk::FBox;
  37. require Tk::Toplevel;
  38.  
  39. use strict;
  40. use vars qw($VERSION $updirImage $folderImage $fileImage);
  41.  
  42. $VERSION = '3.019'; # $Id: //depot/Tk8/Tk/FBox.pm#19 $
  43.  
  44. use base qw(Tk::Toplevel);
  45.  
  46. Construct Tk::Widget 'FBox';
  47.  
  48. my $selectFilePath;
  49. my $selectFile;
  50. my $selectPath;
  51.  
  52. sub import {
  53.     if (defined $_[1] and $_[1] eq 'as_default') {
  54.     local $^W = 0;
  55.     package Tk;
  56.     *FDialog      = \&Tk::FBox::FDialog;
  57.     *MotifFDialog = \&Tk::FBox::FDialog;
  58.     }
  59. }
  60.  
  61. sub Populate {
  62.     my($w, $args) = @_;
  63.  
  64.     require Tk::IconList;
  65.     require File::Basename;
  66.     require Cwd;
  67.  
  68.     $w->SUPER::Populate($args);
  69.  
  70.     # f1: the frame with the directory option menu
  71.     my $f1 = $w->Frame;
  72.     my $lab = $f1->Label(-text => 'Directory:', -underline => 0);
  73.     $w->{'dirMenu'} = my $dirMenu =
  74.       $f1->Optionmenu(-variable => \$w->{'selectPath'},
  75.               -command => ['SetPath', $w]);
  76.     my $upBtn = $f1->Button;
  77.     if (!defined $updirImage) {
  78.     $updirImage = $w->Bitmap(-data => "#define updir_width 28\n" .
  79.                                       "#define updir_height 16\n" .
  80.                           <<EOF);
  81. static char updir_bits[] = {
  82.    0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
  83.    0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
  84.    0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
  85.    0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
  86.    0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
  87.    0xf0, 0xff, 0xff, 0x01};
  88. EOF
  89.     }
  90.     $upBtn->configure(-image => $updirImage);
  91.     $dirMenu->configure(-takefocus => 1, -highlightthickness => 2);
  92.     $upBtn->pack(-side => 'right', -padx => 4, -fill => 'both');
  93.     $lab->pack(-side => 'left', -padx => 4, -fill => 'both');
  94.     $dirMenu->pack(-expand => 'yes', -fill => 'both', -padx => 4);
  95.  
  96.     $w->{'icons'} = my $icons =
  97.       $w->IconList(-browsecmd => ['ListBrowse', $w],
  98.            -command   => ['ListInvoke', $w],
  99.           );
  100.  
  101.     # f2: the frame with the OK button and the "file name" field
  102.     my $f2 = $w->Frame(-bd => 0);
  103.     my $f2_lab = $f2->Label(-text => 'File name:', -anchor => 'e',
  104.                 -width => 14, -underline => 5, -pady => 0);
  105.     $w->{'ent'} = my $ent = $f2->Entry;
  106.  
  107.     # The font to use for the icons. The default Canvas font on Unix
  108.     # is just deviant.
  109. #    $w->{'icons'}{'font'} = $ent->cget(-font);
  110.     $w->{'icons'}->configure(-font => $ent->cget(-font));
  111.  
  112.     # f3: the frame with the cancel button and the file types field
  113.     my $f3 = $w->Frame(-bd => 0);
  114.  
  115.     # The "File of types:" label needs to be grayed-out when
  116.     # -filetypes are not specified. The label widget does not support
  117.     # grayed-out text on monochrome displays. Therefore, we have to
  118.     # use a button widget to emulate a label widget (by setting its
  119.     # bindtags)
  120.     $w->{'typeMenuLab'} = my $typeMenuLab = $f3->Button
  121.       (-text => 'Files of type:',
  122.        -anchor  => 'e',
  123.        -width => 14,
  124.        -underline => 9,
  125.        -bd => $f2_lab->cget(-bd),
  126.        -highlightthickness => $f2_lab->cget(-highlightthickness),
  127.        -relief => $f2_lab->cget(-relief),
  128.        -padx => $f2_lab->cget(-padx),
  129.        -pady => $f2_lab->cget(-pady),
  130.       );
  131.     $typeMenuLab->bindtags([$typeMenuLab, 'Label',
  132.                 $typeMenuLab->toplevel, 'all']);
  133.     $w->{'typeMenuBtn'} = my $typeMenuBtn =
  134.       $f3->Menubutton(-indicatoron => 1, -tearoff => 0);
  135.     $typeMenuBtn->configure(-takefocus => 1,
  136.                 -highlightthickness => 2,
  137.                 -relief => 'raised',
  138.                 -bd => 2,
  139.                 -anchor => 'w',
  140.                );
  141.  
  142.     # the okBtn is created after the typeMenu so that the keyboard traversal
  143.     # is in the right order
  144.     $w->{'okBtn'} = my $okBtn = $f2->Button
  145.       (-text => 'OK',
  146.        -underline => 0,
  147.        -width => 6,
  148.        -default => 'active',
  149.        -pady => 3,
  150.       );
  151.     my $cancelBtn = $f3->Button
  152.       (-text => 'Cancel',
  153.        -underline => 0,
  154.        -width => 6,
  155.        -default => 'normal',
  156.        -pady => 3,
  157.       );
  158.  
  159.     # pack the widgets in f2 and f3
  160.     $okBtn->pack(-side => 'right', -padx => 4, -anchor => 'e');
  161.     $f2_lab->pack(-side => 'left', -padx => 4);
  162.     $ent->pack(-expand => 'yes', -fill => 'x', -padx => 2, -pady => 0);
  163.     $cancelBtn->pack(-side => 'right', -padx => 4, -anchor => 'w');
  164.     $typeMenuLab->pack(-side => 'left', -padx => 4);
  165.     $typeMenuBtn->pack(-expand => 'yes', -fill => 'x', -side => 'right');
  166.  
  167.     # Pack all the frames together. We are done with widget construction.
  168.     $f1->pack(-side => 'top', -fill => 'x', -pady => 4);
  169.     $f3->pack(-side => 'bottom', -fill => 'x');
  170.     $f2->pack(-side => 'bottom', -fill => 'x');
  171.     $icons->pack(-expand => 'yes', -fill => 'both', -padx => 4, -pady => 1);
  172.  
  173.     # Set up the event handlers
  174.     $ent->bind('<Return>',[$w,'ActivateEnt']);
  175.     $upBtn->configure(-command => ['UpDirCmd', $w]);
  176.     $okBtn->configure(-command => ['OkCmd', $w]);
  177.     $cancelBtn->configure(-command, ['CancelCmd', $w]);
  178.  
  179.     $w->bind('<Alt-d>',[$dirMenu,'focus']);
  180.     $w->bind('<Alt-t>',sub  {
  181.                              if ($typeMenuBtn->cget(-state) eq 'normal') {
  182.                              $typeMenuBtn->focus;
  183.                              } });
  184.     $w->bind('<Alt-n>',[$ent,'focus']);
  185.     $w->bind('<KeyPress-Escape>',[$cancelBtn,'invoke']);
  186.     $w->bind('<Alt-c>',[$cancelBtn,'invoke']);
  187.     $w->bind('<Alt-o>',['InvokeBtn','Open']);
  188.     $w->bind('<Alt-s>',['InvokeBtn','Save']);
  189.     $w->protocol('WM_DELETE_WINDOW', ['CancelCmd', $w]);
  190.     $w->OnDestroy(['CancelCmd', $w]);
  191.  
  192.     # Build the focus group for all the entries
  193.     $w->FG_Create;
  194.     $w->FG_BindIn($ent, ['EntFocusIn', $w]);
  195.     $w->FG_BindOut($ent, ['EntFocusOut', $w]);
  196.  
  197.     $w->SetPath(_cwd());
  198.  
  199.     $w->ConfigSpecs(-defaultextension => ['PASSIVE', undef, undef, undef],
  200.             -filetypes        => ['PASSIVE', undef, undef, undef],
  201.             -initialdir       => ['PASSIVE', undef, undef, undef],
  202.             -initialfile      => ['PASSIVE', undef, undef, undef],
  203.             -title            => ['PASSIVE', undef, undef, undef],
  204.             -type             => ['PASSIVE', undef, undef, 'open'],
  205.             -filter           => ['PASSIVE', undef, undef, '*'],
  206.             -force            => ['PASSIVE', undef, undef, 0],
  207.             'DEFAULT'         => [$icons],
  208.            );
  209.     # So-far-failed attempt to break reference loops ...
  210.     $w->_OnDestroy(qw(dirMenu icons typeMenuLab typeMenuBtn okBtn ent updateId));
  211.     $w;
  212. }
  213.  
  214.  
  215. sub Show {
  216.     my $w = shift;
  217.  
  218.     $w->configure(@_);
  219.  
  220.     $w->transient($w->Parent);
  221.  
  222.     # set the default directory and selection according to the -initial
  223.     # settings
  224.     {
  225.     my $initialdir = $w->cget(-initialdir);
  226.     if (defined $initialdir) {
  227.         if (-d $initialdir) {
  228.         $w->{'selectPath'} = $initialdir;
  229.         } else {
  230.         $w->Error("\"$initialdir\" is not a valid directory");
  231.         }
  232.     }
  233.     $w->{'selectFile'} = $w->cget(-initialfile);
  234.     }
  235.  
  236.     # Initialize the file types menu
  237.     my $typeMenuBtn = $w->{'typeMenuBtn'};
  238.     my $typeMenuLab = $w->{'typeMenuLab'};
  239.     if (defined $w->cget('-filetypes')) {
  240.     my(@filetypes) = GetFileTypes($w->cget('-filetypes'));
  241.     my $typeMenu = $typeMenuBtn->cget(-menu);
  242.     $typeMenu->delete(0, 'end');
  243.     foreach my $ft (@filetypes) {
  244.         my $title  = $ft->[0];
  245.         my $filter = join(' ', @{ $ft->[1] });
  246.         $typeMenuBtn->command
  247.           (-label => $title,
  248.            -command => ['SetFilter', $w, $title, $filter],
  249.           );
  250.     }
  251.     $w->SetFilter($filetypes[0]->[0], join(' ', @{ $filetypes[0]->[1] }));
  252.     $typeMenuBtn->configure(-state => 'normal');
  253.     $typeMenuLab->configure(-state => 'normal');
  254.     } else {
  255.     $w->configure(-filter => '*');
  256.     $typeMenuBtn->configure(-state => 'disabled',
  257.                 -takefocus => 0);
  258.     $typeMenuLab->configure(-state => 'disabled');
  259.     }
  260.     $w->UpdateWhenIdle;
  261.  
  262.     # Withdraw the window, then update all the geometry information
  263.     # so we know how big it wants to be, then center the window in the
  264.     # display and de-iconify it.
  265.     $w->withdraw;
  266.     $w->idletasks;
  267.     my $x = int($w->screenwidth / 2 - $w->reqwidth / 2 - $w->parent->vrootx);
  268.     my $y = int($w->screenheight / 2 - $w->reqheight / 2 - $w->parent->vrooty);
  269.     $w->geometry("+$x+$y");
  270.  
  271.     {
  272.     my $title = $w->cget(-title);
  273.     if (!defined $title) {
  274.         $title = ($w->cget(-type) eq 'open' ? 'Open' : 'Save As');
  275.     }
  276.     $w->title($title);
  277.     }
  278.  
  279.     $w->deiconify;
  280.     # Set a grab and claim the focus too.
  281.     my $oldFocus = $w->focusCurrent;
  282.     my $oldGrab = $w->grabCurrent;
  283.     my $grabStatus = $oldGrab->grabStatus if ($oldGrab);
  284.     $w->grab;
  285.     my $ent = $w->{'ent'};
  286.     $ent->focus;
  287.     $ent->delete(0, 'end');
  288.     $ent->insert(0, $w->{'selectFile'});
  289.     $ent->selectionFrom(0);
  290.     $ent->selectionTo('end');
  291.     $ent->icursor('end');
  292.  
  293.     # 8. Wait for the user to respond, then restore the focus and
  294.     # return the index of the selected button.  Restore the focus
  295.     # before deleting the window, since otherwise the window manager
  296.     # may take the focus away so we can't redirect it.  Finally,
  297.     # restore any grab that was in effect.
  298.     $w->waitVariable(\$selectFilePath);
  299.     eval {
  300.     $oldFocus->focus if $oldFocus;
  301.     };
  302.     if (Tk::Exists($w)) { # widget still exists
  303.     $w->grabRelease;
  304.     $w->withdraw;
  305.     }
  306.     if ($oldGrab) {
  307.     if ($grabStatus eq 'global') {
  308.         $oldGrab->grabGlobal;
  309.     } else {
  310.         $oldGrab->grab;
  311.     }
  312.     }
  313.     return $selectFilePath;
  314. }
  315.  
  316. # tkFDialog_UpdateWhenIdle --
  317. #
  318. #    Creates an idle event handler which updates the dialog in idle
  319. #    time. This is important because loading the directory may take a long
  320. #    time and we don't want to load the same directory for multiple times
  321. #    due to multiple concurrent events.
  322. #
  323. sub UpdateWhenIdle {
  324.     my $w = shift;
  325.     if (exists $w->{'updateId'}) {
  326.     return;
  327.     } else {
  328.     $w->{'updateId'} = $w->after('idle', [$w, 'Update']);
  329.     }
  330. }
  331.  
  332. # tkFDialog_Update --
  333. #
  334. #    Loads the files and directories into the IconList widget. Also
  335. #    sets up the directory option menu for quick access to parent
  336. #    directories.
  337. #
  338. sub Update {
  339.     my $w = shift;
  340.     my $dataName = $w->name;
  341.  
  342.     # This proc may be called within an idle handler. Make sure that the
  343.     # window has not been destroyed before this proc is called
  344.     if (!Tk::Exists($w) || $w->class ne 'FBox') {
  345.     return;
  346.     } else {
  347.     delete $w->{'updateId'};
  348.     }
  349.     unless (defined $folderImage) {
  350.     require Tk::Pixmap;
  351.     $folderImage = $w->Pixmap(-file => Tk->findINC('folder.xpm'));
  352.     $fileImage   = $w->Pixmap(-file => Tk->findINC('file.xpm'));
  353.     }
  354.     my $folder = $folderImage;
  355.     my $file   = $fileImage;
  356.     my $appPWD = _cwd();
  357.     if (!ext_chdir($w->{'selectPath'})) {
  358.     # We cannot change directory to $data(selectPath). $data(selectPath)
  359.     # should have been checked before tkFDialog_Update is called, so
  360.     # we normally won't come to here. Anyways, give an error and abort
  361.     # action.
  362.     $w->messageBox(-type => 'OK',
  363.                -message => 'Cannot change to the directory "' .
  364.                $w->{'selectPath'} . "\".\nPermission denied.",
  365.                -icon => 'warning',
  366.               );
  367.     ext_chdir($appPWD);
  368.     return;
  369.     }
  370.  
  371.     # Turn on the busy cursor. BUG?? We haven't disabled X events, though,
  372.     # so the user may still click and cause havoc ...
  373.     my $ent = $w->{'ent'};
  374.     my $entCursor = $ent->cget(-cursor);
  375.     my $dlgCursor = $w->cget(-cursor);
  376.     $ent->configure(-cursor => 'watch');
  377.     $w->configure(-cursor => 'watch');
  378.     $w->idletasks;
  379.     my $icons = $w->{'icons'};
  380.     $icons->DeleteAll;
  381.  
  382.     # Make the dir & file list
  383.     my $flt = join('|', split(' ', $w->cget(-filter)) );
  384.     $flt =~ s!([\.\+])!\\$1!g;
  385.     $flt =~ s!\*!.*!g;
  386.     local *FDIR;
  387.     if( opendir( FDIR,  _cwd() )) {
  388.       my @files;
  389.         foreach my $f (sort { lc($a) cmp lc($b) } readdir FDIR) {
  390.           next if $f eq '.' or $f eq '..';
  391.           if (-d $f) { $icons->Add($folder, $f); }
  392.           elsif( $f =~ m!$flt$! ) { push( @files, $f ); }
  393.     }
  394.       closedir( FDIR );
  395.       foreach my $f ( @files ) { $icons->Add($file, $f); }
  396.     }
  397.  
  398.     $icons->Arrange;
  399.  
  400.     # Update the Directory: option menu
  401.     my @list;
  402.     my $dir = '';
  403.     foreach my $subdir (TclFileSplit($w->{'selectPath'})) {
  404.     $dir = TclFileJoin($dir, $subdir);
  405.     push @list, $dir;
  406.     }
  407.     my $dirMenu = $w->{'dirMenu'};
  408.     $dirMenu->configure(-options => \@list);
  409.  
  410.     # Restore the PWD to the application's PWD
  411.     ext_chdir($appPWD);
  412.  
  413.     # Restore the Save label
  414.     if ($w->cget(-type) eq 'save') {
  415.     $w->{'okBtn'}->configure(-text => 'Save');
  416.     }
  417.  
  418.     # turn off the busy cursor.
  419.     $ent->configure(-cursor => $entCursor);
  420.     $w->configure(-cursor =>  $dlgCursor);
  421. }
  422.  
  423. # tkFDialog_SetPathSilently --
  424. #
  425. #     Sets data(selectPath) without invoking the trace procedure
  426. #
  427. sub SetPathSilently {
  428.     my($w, $path) = @_;
  429.  
  430.     $w->{'selectPath'} = $path;
  431. }
  432.  
  433. # This proc gets called whenever data(selectPath) is set
  434. #
  435. sub SetPath {
  436.     my $w = shift;
  437.     $w->{'selectPath'} = $_[0] if @_;
  438.     $w->UpdateWhenIdle;
  439. }
  440.  
  441. # This proc gets called whenever data(filter) is set
  442. #
  443. sub SetFilter {
  444.     my($w, $title, $filter) = @_;
  445.     $w->configure(-filter => $filter);
  446.     $w->{'typeMenuBtn'}->configure(-text => $title,
  447.                    -indicatoron => 1);
  448.     $w->{'icons'}->Subwidget('sbar')->set(0.0, 0.0);
  449.     $w->UpdateWhenIdle;
  450. }
  451.  
  452. # tkFDialogResolveFile --
  453. #
  454. #    Interpret the user's text input in a file selection dialog.
  455. #    Performs:
  456. #
  457. #    (1) ~ substitution
  458. #    (2) resolve all instances of . and ..
  459. #    (3) check for non-existent files/directories
  460. #    (4) check for chdir permissions
  461. #
  462. # Arguments:
  463. #    context:  the current directory you are in
  464. #    text:      the text entered by the user
  465. #    defaultext: the default extension to add to files with no extension
  466. #
  467. # Return value:
  468. #    [list $flag $directory $file]
  469. #
  470. #     flag = OK    : valid input
  471. #          = PATTERN    : valid directory/pattern
  472. #          = PATH    : the directory does not exist
  473. #          = FILE    : the directory exists but the file doesn't
  474. #              exist
  475. #          = CHDIR    : Cannot change to the directory
  476. #          = ERROR    : Invalid entry
  477. #
  478. #     directory      : valid only if flag = OK or PATTERN or FILE
  479. #     file           : valid only if flag = OK or PATTERN
  480. #
  481. #    directory may not be the same as context, because text may contain
  482. #    a subdirectory name
  483. #
  484. sub ResolveFile {
  485.     my($context, $text, $defaultext) = @_;
  486.     my $appPWD = _cwd();
  487.     my $path = JoinFile($context, $text);
  488.     $path = "$path$defaultext" if ($path !~ /\..+$/) and defined $defaultext;
  489.     # Cannot just test for existance here as non-existing files are
  490.     # not an error for getSaveFile type dialogs.
  491.     # return ('ERROR', $path, "") if (!-e $path);
  492.     my($directory, $file, $flag);
  493.     if (-e $path) {
  494.     if (-d $path) {
  495.         if (!ext_chdir($path)) {
  496.         return ('CHDIR', $path, '');
  497.         }
  498.         $directory = _cwd();
  499.         $file = '';
  500.         $flag = 'OK';
  501.         ext_chdir($appPWD);
  502.     } else {
  503.         my $dirname = File::Basename::dirname($path);
  504.         if (!ext_chdir($dirname)) {
  505.         return ('CHDIR', $dirname, '');
  506.         }
  507.         $directory = _cwd();
  508.         $file = File::Basename::basename($path);
  509.         $flag = 'OK';
  510.         ext_chdir($appPWD);
  511.     }
  512.     } else {
  513.     my $dirname = File::Basename::dirname($path);
  514.     if (-e $dirname) {
  515.         if (!ext_chdir($dirname)) {
  516.         return ('CHDIR', $dirname, '');
  517.         }
  518.         $directory = _cwd();
  519.         $file = File::Basename::basename($path);
  520.         if ($file =~ /[*?]/) {
  521.         $flag = 'PATTERN';
  522.         } else {
  523.         $flag = 'FILE';
  524.         }
  525.         ext_chdir($appPWD);
  526.     } else {
  527.         $directory = $dirname;
  528.         $file = File::Basename::basename($path);
  529.         $flag = 'PATH';
  530.     }
  531.     }
  532.     return ($flag,$directory,$file);
  533. }
  534.  
  535. # Gets called when the entry box gets keyboard focus. We clear the selection
  536. # from the icon list . This way the user can be certain that the input in the
  537. # entry box is the selection.
  538. #
  539. sub EntFocusIn {
  540.     my $w = shift;
  541.     my $ent = $w->{'ent'};
  542.     if ($ent->get ne '') {
  543.     $ent->selectionFrom(0);
  544.     $ent->selectionTo('end');
  545.     $ent->icursor('end');
  546.     } else {
  547.     $ent->selectionClear;
  548.     }
  549.     $w->{'icons'}->Unselect;
  550.     my $okBtn = $w->{'okBtn'};
  551.     if ($w->cget(-type) eq 'open') {
  552.     $okBtn->configure(-text => 'Open');
  553.     } else {
  554.     $okBtn->configure(-text => 'Save');
  555.     }
  556. }
  557.  
  558. sub EntFocusOut {
  559.     my $w = shift;
  560.     $w->{'ent'}->selectionClear;
  561. }
  562.  
  563. # Gets called when user presses Return in the "File name" entry.
  564. #
  565. sub ActivateEnt {
  566.     my $w = shift;
  567.     my $ent = $w->{'ent'};
  568.     my $text = $ent->get;
  569.     $text =~ s/^\s+//;
  570.     $text =~ s/\s+$//;
  571.     my($flag, $path, $file) = ResolveFile($w->{'selectPath'}, $text,
  572.                       $w->cget(-defaultextension));
  573.     if ($flag eq 'OK') {
  574.     if ($file eq '') {
  575.         # user has entered an existing (sub)directory
  576.         $w->SetPath($path);
  577.         $ent->delete(0, 'end');
  578.     } else {
  579.         $w->SetPathSilently($path);
  580.         $w->{'selectFile'} = $file;
  581.         $w->Done;
  582.     }
  583.     } elsif ($flag eq 'PATTERN') {
  584.     $w->SetPath($path);
  585.     $w->configure(-filter => $file);
  586.     } elsif ($flag eq 'FILE') {
  587.     if ($w->cget(-type) eq 'open') {
  588.         $w->messageBox(-icon => 'warning',
  589.                -type => 'OK',
  590.                -message => 'File "' . TclFileJoin($path, $file)
  591.                . '" does not exist.');
  592.         $ent->selection('from', 0);
  593.         $ent->selection('to', 'end');
  594.         $ent->icursor('end');
  595.     } else {
  596.         $w->SetPathSilently($path);
  597.         $w->{'selectFile'} = $file;
  598.         $w->Done;
  599.     }
  600.     } elsif ($flag eq 'PATH') {
  601.     $w->messageBox(-icon => 'warning',
  602.                -type => 'OK',
  603.                -message => "Directory \'$path\' does not exist.");
  604.     $ent->selection('from', 0);
  605.     $ent->selection('to', 'end');
  606.     $ent->icursor('end');
  607.     } elsif ($flag eq 'CHDIR') {
  608.     $w->messageBox(-type => 'OK',
  609.                -message => "Cannot change to the directory \"$path\".\nPermission denied.",
  610.                -icon => 'warning');
  611.     $ent->selection('from', 0);
  612.     $ent->selection('to', 'end');
  613.     $ent->icursor('end');
  614.     } elsif ($flag eq 'ERROR') {
  615.     $w->messageBox(-type => 'OK',
  616.                -message => "Invalid file name \"$path\".",
  617.                -icon => 'warning');
  618.     $ent->selection('from', 0);
  619.     $ent->selection('to', 'end');
  620.     $ent->icursor('end');
  621.     }
  622. }
  623.  
  624. # Gets called when user presses the Alt-s or Alt-o keys.
  625. #
  626. sub InvokeBtn {
  627.     my($w, $key) = @_;
  628.     my $okBtn = $w->{'okBtn'};
  629.     $okBtn->invoke if ($okBtn->cget(-text) eq $key);
  630. }
  631.  
  632. # Gets called when user presses the "parent directory" button
  633. #
  634. sub UpDirCmd {
  635.     my $w = shift;
  636.     $w->SetPath(File::Basename::dirname($w->{'selectPath'}))
  637.       unless ($w->{'selectPath'} eq '/');
  638. }
  639.  
  640. # Join a file name to a path name. The "file join" command will break
  641. # if the filename begins with ~
  642. sub JoinFile {
  643.     my($path, $file) = @_;
  644.     if ($file =~ /^~/ && -e "$path/$file") {
  645.     TclFileJoin($path, "./$file");
  646.     } else {
  647.     TclFileJoin($path, $file);
  648.     }
  649. }
  650.  
  651. # XXX replace with File::Spec when perl/Tk depends on 5.005
  652. sub TclFileJoin {
  653.     my $path = '';
  654.     foreach (@_) {
  655.     if (m|^/|) {
  656.         $path = $_;
  657.     }
  658.     elsif (m|^[a-z]:/|i) {  # DOS-ish
  659.         $path = $_;
  660.     } elsif ($_ eq '~') {
  661.         $path = _get_homedir();
  662.     } elsif (m|^~/(.*)|) {
  663.         $path = _get_homedir() . "/" . $1;
  664.     } elsif (m|^~([^/]+)(.*)|) {
  665.         my($user, $p) = ($1, $2);
  666.         my $dir = _get_homedir($user);
  667.         if (!defined $dir) {
  668.         $path = "~$user$p";
  669.         } else {
  670.         $path = $dir . $p;
  671.         }
  672.     } elsif ($path eq '/' or $path eq '') {
  673.         $path .= $_;
  674.     } else {
  675.         $path .= "/$_";
  676.     }
  677.     }
  678.     $path;
  679. }
  680.  
  681. sub TclFileSplit {
  682.     my $path = shift;
  683.     my @comp;
  684.     $path =~ s|/+|/|g; # strip multiple slashes
  685.     if ($path =~ m|^/|) {
  686.     push @comp, '/';
  687.     $path = substr($path, 1);
  688.     }
  689.     push @comp, split /\//, $path;
  690.     @comp;
  691. }
  692.  
  693. # Gets called when user presses the "OK" button
  694. #
  695. sub OkCmd {
  696.     my $w = shift;
  697.     my $text = $w->{'icons'}->Get;
  698.     if (defined $text and $text ne '') {
  699.     my $file = JoinFile($w->{'selectPath'}, $text);
  700.     if (-d $file) {
  701.         $w->ListInvoke($text);
  702.         return;
  703.     }
  704.     }
  705.     $w->ActivateEnt;
  706. }
  707.  
  708. # Gets called when user presses the "Cancel" button
  709. #
  710. sub CancelCmd {
  711.     undef $selectFilePath;
  712. }
  713.  
  714. # Gets called when user browses the IconList widget (dragging mouse, arrow
  715. # keys, etc)
  716. #
  717. sub ListBrowse {
  718.     my($w, $text) = @_;
  719.     return if ($text eq '');
  720.     my $file = JoinFile($w->{'selectPath'}, $text);
  721.     my $ent = $w->{'ent'};
  722.     my $okBtn = $w->{'okBtn'};
  723.     unless (-d $file) {
  724.     $ent->delete(0, 'end');
  725.     $ent->insert(0, $text);
  726.     if ($w->cget(-type) eq 'open') {
  727.         $okBtn->configure(-text => 'Open');
  728.     } else {
  729.         $okBtn->configure(-text => 'Save');
  730.     }
  731.     } else {
  732.     $okBtn->configure(-text => 'Open');
  733.     }
  734. }
  735.  
  736. # Gets called when user invokes the IconList widget (double-click,
  737. # Return key, etc)
  738. #
  739. sub ListInvoke {
  740.     my($w, $text) = @_;
  741.     return if ($text eq '');
  742.     my $file = JoinFile($w->{'selectPath'}, $text);
  743.     if (-d $file) {
  744.     my $appPWD = _cwd();
  745.     if (!ext_chdir($file)) {
  746.         $w->messageBox(-type => 'OK',
  747.                -message => "Cannot change to the directory \"$file\".\nPermission denied.",
  748.                -icon => 'warning');
  749.     } else {
  750.         ext_chdir($appPWD);
  751.         $w->SetPath($file);
  752.     }
  753.     } else {
  754.     $w->{'selectFile'} = $file;
  755.     $w->Done;
  756.     }
  757. }
  758.  
  759. # tkFDialog_Done --
  760. #
  761. #    Gets called when user has input a valid filename.  Pops up a
  762. #    dialog box to confirm selection when necessary. Sets the
  763. #    tkPriv(selectFilePath) variable, which will break the "tkwait"
  764. #    loop in tkFDialog and return the selected filename to the
  765. #    script that calls tk_getOpenFile or tk_getSaveFile
  766. #
  767. sub Done {
  768.     my $w = shift;
  769.     my $_selectFilePath = (@_) ? shift : '';
  770.     if ($_selectFilePath eq '') {
  771.     $_selectFilePath = JoinFile($w->{'selectPath'}, $w->{'selectFile'});
  772.     if (-e $_selectFilePath and
  773.         $w->cget(-type) eq 'save' and
  774.         !$w->cget(-force)) {
  775.         my $reply = $w->messageBox
  776.           (-icon => 'warning',
  777.            -type => 'YesNo',
  778.            -message => "File \"$_selectFilePath\" already exists.\nDo you want to overwrite it?");
  779.         return unless (lc($reply) eq 'yes');
  780.     }
  781.     }
  782.     $selectFilePath = ($_selectFilePath ne '' ? $_selectFilePath : undef);
  783. }
  784.  
  785. sub FDialog {
  786.     my $cmd = shift;
  787.     if ($cmd =~ /Save/) {
  788.     push @_, -type => 'save';
  789.     }
  790.     Tk::DialogWrapper('FBox', $cmd, @_);
  791. }
  792.  
  793. # tkFDGetFileTypes --
  794. #
  795. #       Process the string given by the -filetypes option of the file
  796. #       dialogs. Similar to the C function TkGetFileFilters() on the Mac
  797. #       and Windows platform.
  798. #
  799. sub GetFileTypes {
  800.     my $in = shift;
  801.     my %fileTypes;
  802.     foreach my $t (@$in) {
  803.         if (@$t < 2  || @$t > 3) {
  804.         require Carp;
  805.         Carp::croak("bad file type \"$t\", should be \"typeName [extension ?extensions ...?] ?[macType ?macTypes ...?]?\"");
  806.         }
  807.     push @{ $fileTypes{$t->[0]} }, (ref $t->[1] eq 'ARRAY'
  808.                     ? @{ $t->[1] }
  809.                     : $t->[1]);
  810.     }
  811.  
  812.     my @types;
  813.     my %hasDoneType;
  814.     my %hasGotExt;
  815.     foreach my $t (@$in) {
  816.         my $label = $t->[0];
  817.         my @exts;
  818.  
  819.         next if (exists $hasDoneType{$label});
  820.  
  821.         my $name = "$label (";
  822.     my $sep = '';
  823.         foreach my $ext (@{ $fileTypes{$label} }) {
  824.             next if ($ext eq '');
  825.             $ext =~ s/^\./*./;
  826.             if (!exists $hasGotExt{$label}->{$ext}) {
  827.                 $name .= "$sep$ext";
  828.                 push @exts, $ext;
  829.                 $hasGotExt{$label}->{$ext}++;
  830.             }
  831.             $sep = ',';
  832.         }
  833.         $name .= ')';
  834.         push @types, [$name, \@exts];
  835.  
  836.         $hasDoneType{$label}++;
  837.     }
  838.  
  839.     return @types;
  840. }
  841.  
  842. # ext_chdir --
  843. #
  844. #       Change directory with tilde substitution
  845. #
  846. sub ext_chdir {
  847.     my $dir = shift;
  848.     if ($dir eq '~') {
  849.     chdir _get_homedir();
  850.     } elsif ($dir =~ m|^~/(.*)|) {
  851.     chdir _get_homedir() . "/" . $1;
  852.     } elsif ($dir =~ m|^~([^/]+(.*))|) {
  853.     chdir _get_homedir($1) . $2;
  854.     } else {
  855.     chdir $dir;
  856.     }
  857. }
  858.  
  859. # _get_homedir --
  860. #
  861. #       Get home directory of the current user
  862. #
  863. sub _get_homedir {
  864.     my($user) = @_;
  865.     if (!defined $user) {
  866.     eval {
  867.         local $SIG{__DIE__};
  868.         (getpwuid($<))[7];
  869.     } || $ENV{HOME} || undef; # chdir undef changes to home directory, too
  870.     } else {
  871.     eval {
  872.         local $SIG{__DIE__};
  873.         (getpwnam($user))[7];
  874.     };
  875.     }
  876. }
  877.  
  878. sub _cwd {
  879.     #Cwd::cwd();
  880.     Cwd::fastcwd(); # this is taint-safe
  881. }
  882.  
  883. sub _untaint {
  884.     my $s = shift;
  885.     $s =~ /^(.*)$/;
  886.     $1;
  887. }
  888.  
  889. 1;
  890.  
  891.