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