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