diff options
Diffstat (limited to 'Master/tlpkg/tlperl.old/lib/Tk/FBox.pm')
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/FBox.pm | 1043 |
1 files changed, 0 insertions, 1043 deletions
diff --git a/Master/tlpkg/tlperl.old/lib/Tk/FBox.pm b/Master/tlpkg/tlperl.old/lib/Tk/FBox.pm deleted file mode 100644 index fed7501aea4..00000000000 --- a/Master/tlpkg/tlperl.old/lib/Tk/FBox.pm +++ /dev/null @@ -1,1043 +0,0 @@ -# -*- perl -*- -# -# tkfbox.tcl -- -# -# Implements the "TK" standard file selection dialog box. This -# dialog box is used on the Unix platforms whenever the tk_strictMotif -# flag is not set. -# -# The "TK" standard file selection dialog box is similar to the -# file selection dialog box on Win95(TM). The user can navigate -# the directories by clicking on the folder icons or by -# selecting the "Directory" option menu. The user can select -# files by clicking on the file icons or by entering a filename -# in the "Filename:" entry. -# -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# Translated to perl/Tk by Slaven Rezic <slaven@rezic.de>. -# - -#---------------------------------------------------------------------- -# -# F I L E D I A L O G -# -#---------------------------------------------------------------------- -# tkFDialog -- -# -# Implements the TK file selection dialog. This dialog is used when -# the tk_strictMotif flag is set to false. This procedure shouldn't -# be called directly. Call tk_getOpenFile or tk_getSaveFile instead. -# - -package Tk::FBox; -require Tk::Toplevel; - -use strict; -use vars qw($VERSION $updirImage $folderImage $fileImage); - -$VERSION = sprintf '4.%03d', q$Revision: #18 $ =~ /\D(\d+)\s*$/; - -use base qw(Tk::Toplevel); - -Construct Tk::Widget 'FBox'; - -sub import { - if (defined $_[1] and $_[1] eq 'as_default') { - local $^W = 0; - package Tk; - if ($Tk::VERSION < 804) { - *FDialog = \&Tk::FBox::FDialog; - *MotifFDialog = \&Tk::FBox::FDialog; - } else { - *tk_getOpenFile = sub { - Tk::FBox::FDialog("tk_getOpenFile", @_); - }; - *tk_getSaveFile = sub { - Tk::FBox::FDialog("tk_getSaveFile", @_); - }; - } - } -} - -# Note that -sortcmd is experimental and the interface is likely to change. -# Using -sortcmd is really strange :-( -# $top->getOpenFile(-sortcmd => sub { package Tk::FBox; uc $b cmp uc $a}); -# or, un-perlish, but useable (now activated in code): -# $top->getOpenFile(-sortcmd => sub { uc $_[1] cmp uc $_[0]}); - -sub Populate { - my($w, $args) = @_; - - require Tk::IconList; - require File::Basename; - require Cwd; - - $w->SUPER::Populate($args); - - # f1: the frame with the directory option menu - my $f1 = $w->Frame; - my $lab = $f1->Label(-text => 'Directory:', -underline => 0); - $w->{'dirMenu'} = my $dirMenu = - $f1->Optionmenu(-variable => \$w->{'selectPath'}, - -textvariable => \$w->{'selectPath'}, - -command => ['SetPath', $w]); - my $upBtn = $f1->Button; - if (!defined $updirImage->{$w->MainWindow}) { - $updirImage->{$w->MainWindow} = $w->Bitmap(-data => <<EOF); -#define updir_width 28 -#define updir_height 16 -static char updir_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00, - 0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01, - 0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01, - 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, - 0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01, - 0xf0, 0xff, 0xff, 0x01}; -EOF - } - $upBtn->configure(-image => $updirImage->{$w->MainWindow}); - $dirMenu->configure(-takefocus => 1, -highlightthickness => 2); - $upBtn->pack(-side => 'right', -padx => 4, -fill => 'both'); - $lab->pack(-side => 'left', -padx => 4, -fill => 'both'); - $dirMenu->pack(-expand => 'yes', -fill => 'both', -padx => 4); - - $w->{'icons'} = my $icons = - $w->IconList(-command => ['OkCmd', $w, 'iconlist'], - ); - $icons->bind('<<ListboxSelect>>' => [$w, 'ListBrowse']); - - # f2: the frame with the OK button and the "file name" field - my $f2 = $w->Frame(-bd => 0); -#XXX File name => File names if multiple - my $f2_lab = $f2->Label(-text => 'File name:', -anchor => 'e', - -width => 14, -underline => 5, -pady => 0); - $w->{'ent'} = my $ent = $f2->Entry; - - # The font to use for the icons. The default Canvas font on Unix - # is just deviant. -# $w->{'icons'}{'font'} = $ent->cget(-font); - $w->{'icons'}->configure(-font => $ent->cget(-font)); - - # f3: the frame with the cancel button and the file types field - my $f3 = $w->Frame(-bd => 0); - - # The "File of types:" label needs to be grayed-out when - # -filetypes are not specified. The label widget does not support - # grayed-out text on monochrome displays. Therefore, we have to - # use a button widget to emulate a label widget (by setting its - # bindtags) - $w->{'typeMenuLab'} = my $typeMenuLab = $f3->Button - (-text => 'Files of type:', - -anchor => 'e', - -width => 14, - -underline => 9, - -bd => $f2_lab->cget(-bd), - -highlightthickness => $f2_lab->cget(-highlightthickness), - -relief => $f2_lab->cget(-relief), - -padx => $f2_lab->cget(-padx), - -pady => $f2_lab->cget(-pady), - -takefocus => 0, - ); - $typeMenuLab->bindtags([$typeMenuLab, 'Label', - $typeMenuLab->toplevel, 'all']); - $w->{'typeMenuBtn'} = my $typeMenuBtn = - $f3->Menubutton(-indicatoron => 1, -tearoff => 0); - $typeMenuBtn->configure(-takefocus => 1, - -highlightthickness => 2, - -relief => 'raised', - -bd => 2, - -anchor => 'w', - ); - - # the okBtn is created after the typeMenu so that the keyboard traversal - # is in the right order - $w->{'okBtn'} = my $okBtn = $f2->Button - (-text => 'OK', - -underline => 0, - -width => 6, - -default => 'active', - -pady => 3, - ); - my $cancelBtn = $f3->Button - (-text => 'Cancel', - -underline => 0, - -width => 6, - -default => 'normal', - -pady => 3, - ); - - # pack the widgets in f2 and f3 - $okBtn->pack(-side => 'right', -padx => 4, -anchor => 'e'); - $f2_lab->pack(-side => 'left', -padx => 4); - $ent->pack(-expand => 'yes', -fill => 'x', -padx => 2, -pady => 0); - $cancelBtn->pack(-side => 'right', -padx => 4, -anchor => 'w'); - $typeMenuLab->pack(-side => 'left', -padx => 4); - $typeMenuBtn->pack(-expand => 'yes', -fill => 'x', -side => 'right'); - - # Pack all the frames together. We are done with widget construction. - $f1->pack(-side => 'top', -fill => 'x', -pady => 4); - $f3->pack(-side => 'bottom', -fill => 'x'); - $f2->pack(-side => 'bottom', -fill => 'x'); - $icons->pack(-expand => 'yes', -fill => 'both', -padx => 4, -pady => 1); - - # Set up the event handlers - $ent->bind('<Return>',[$w,'ActivateEnt']); - $upBtn->configure(-command => ['UpDirCmd', $w]); - $okBtn->configure(-command => ['OkCmd', $w]); - $cancelBtn->configure(-command, ['CancelCmd', $w]); - - $w->bind('<Alt-d>',[$dirMenu,'focus']); - $w->bind('<Alt-t>',sub { - if ($typeMenuBtn->cget(-state) eq 'normal') { - $typeMenuBtn->focus; - } }); - $w->bind('<Alt-n>',[$ent,'focus']); - $w->bind('<KeyPress-Escape>',[$cancelBtn,'invoke']); - $w->bind('<Alt-c>',[$cancelBtn,'invoke']); - $w->bind('<Alt-o>',['InvokeBtn','Open']); - $w->bind('<Alt-s>',['InvokeBtn','Save']); - $w->protocol('WM_DELETE_WINDOW', ['CancelCmd', $w]); - $w->OnDestroy(['CancelCmd', $w]); - - # Build the focus group for all the entries - $w->FG_Create; - $w->FG_BindIn($ent, ['EntFocusIn', $w]); - $w->FG_BindOut($ent, ['EntFocusOut', $w]); - - $w->SetPath(_cwd()); - - $w->ConfigSpecs(-defaultextension => ['PASSIVE', undef, undef, undef], - -filetypes => ['PASSIVE', undef, undef, undef], - -initialdir => ['PASSIVE', undef, undef, undef], - -initialfile => ['PASSIVE', undef, undef, undef], -# -sortcmd => ['PASSIVE', undef, undef, sub { lc($a) cmp lc($b) }], - -sortcmd => ['PASSIVE', undef, undef, sub { lc($_[0]) cmp lc($_[1]) }], - -title => ['PASSIVE', undef, undef, undef], - -type => ['PASSIVE', undef, undef, 'open'], - -filter => ['PASSIVE', undef, undef, '*'], - -force => ['PASSIVE', undef, undef, 0], - -multiple => ['PASSIVE', undef, undef, 0], - 'DEFAULT' => [$icons], - ); - # So-far-failed attempt to break reference loops ... - $w->_OnDestroy(qw(dirMenu icons typeMenuLab typeMenuBtn okBtn ent updateId)); - $w; -} - -# -initialdir fix with ResolveFile -sub Show { - my $w = shift; - - $w->configure(@_); - - # Dialog boxes should be transient with respect to their parent, - # so that they will always stay on top of their parent window. However, - # some window managers will create the window as withdrawn if the parent - # window is withdrawn or iconified. Combined with the grab we put on the - # window, this can hang the entire application. Therefore we only make - # the dialog transient if the parent is viewable. - - if (Tk::Exists($w->Parent) && $w->Parent->viewable) { - $w->transient($w->Parent); - } - - # set the default directory and selection according to the -initial - # settings - { - my $initialdir = $w->cget(-initialdir); - if (defined $initialdir) { - my ($flag, $path, $file) = ResolveFile($initialdir, 'junk'); - if ($flag eq 'OK' or $flag eq 'FILE') { - $w->{'selectPath'} = $path; - } else { - $w->Error("\"$initialdir\" is not a valid directory"); - } - } - $w->{'selectFile'} = $w->cget(-initialfile); - } - - # Set -multiple to a one or zero value (not other boolean types - # like "yes") so we can use it in tests more easily. - if ($w->cget('-type') ne 'open') { - $w->configure(-multiple => 0); - } else { - $w->configure(-multiple => !!$w->cget('-multiple')); - } - $w->{'icons'}->configure(-multiple => $w->cget('-multiple')); - - # Initialize the file types menu - my $typeMenuBtn = $w->{'typeMenuBtn'}; - my $typeMenuLab = $w->{'typeMenuLab'}; - if (defined $w->cget('-filetypes')) { - my(@filetypes) = GetFileTypes($w->cget('-filetypes')); - my $typeMenu = $typeMenuBtn->cget(-menu); - $typeMenu->delete(0, 'end'); - foreach my $ft (@filetypes) { - my $title = $ft->[0]; - my $filter = join(' ', @{ $ft->[1] }); - $typeMenuBtn->command - (-label => $title, - -command => ['SetFilter', $w, $title, $filter], - ); - } - $w->SetFilter($filetypes[0]->[0], join(' ', @{ $filetypes[0]->[1] })); - $typeMenuBtn->configure(-state => 'normal'); - $typeMenuLab->configure(-state => 'normal'); - } else { -#XXX $w->configure(-filter => '*'); - $typeMenuBtn->configure(-state => 'disabled', - -takefocus => 0); - $typeMenuLab->configure(-state => 'disabled'); - } - $w->UpdateWhenIdle; - - { - my $title = $w->cget(-title); - if (!defined $title) { - my $type = $w->cget(-type); - $title = ($type eq 'dir') ? 'Choose Directory' - : ($type eq 'save') ? 'Save As' : 'Open'; - } - $w->title($title); - } - - # Withdraw the window, then update all the geometry information - # so we know how big it wants to be, then center the window in the - # display and de-iconify it. - $w->withdraw; - $w->idletasks; - if (0) - { - #XXX use Tk::Wm::Popup? or Tk::PlaceWindow? - my $x = int($w->screenwidth / 2 - $w->reqwidth / 2 - $w->parent->vrootx); - my $y = int($w->screenheight / 2 - $w->reqheight / 2 - $w->parent->vrooty); - $w->geometry("+$x+$y"); - $w->deiconify; - } - else - { - $w->Popup; - } - - # Set a grab and claim the focus too. -#XXX use Tk::setFocusGrab when it's available - my $oldFocus = $w->focusCurrent; - my $oldGrab = $w->grabCurrent; - my $grabStatus = $oldGrab->grabStatus if ($oldGrab); - $w->grab; - my $ent = $w->{'ent'}; - $ent->focus; - $ent->delete(0, 'end'); - if (defined $w->{'selectFile'} && $w->{'selectFile'} ne '') { - $ent->insert(0, $w->{'selectFile'}); - $ent->selectionRange(0,'end'); - $ent->icursor('end'); - } - - # 8. Wait for the user to respond, then restore the focus and - # return the index of the selected button. Restore the focus - # before deleting the window, since otherwise the window manager - # may take the focus away so we can't redirect it. Finally, - # restore any grab that was in effect. - $w->waitVariable(\$w->{'selectFilePath'}); - eval { - $oldFocus->focus if $oldFocus; - }; - if (Tk::Exists($w)) { # widget still exists - $w->grabRelease; - $w->withdraw; - } - if (Tk::Exists($oldGrab) && $oldGrab->viewable) { - if ($grabStatus eq 'global') { - $oldGrab->grabGlobal; - } else { - $oldGrab->grab; - } - } - return $w->{'selectFilePath'}; -} - -# tkFDialog_UpdateWhenIdle -- -# -# Creates an idle event handler which updates the dialog in idle -# time. This is important because loading the directory may take a long -# time and we don't want to load the same directory for multiple times -# due to multiple concurrent events. -# -sub UpdateWhenIdle { - my $w = shift; - if (exists $w->{'updateId'}) { - return; - } else { - $w->{'updateId'} = $w->after('idle', [$w, 'Update']); - } -} - -# tkFDialog_Update -- -# -# Loads the files and directories into the IconList widget. Also -# sets up the directory option menu for quick access to parent -# directories. -# -sub Update { - my $w = shift; - my $dataName = $w->name; - - # This proc may be called within an idle handler. Make sure that the - # window has not been destroyed before this proc is called - if (!Tk::Exists($w) || $w->class ne 'FBox') { - return; - } else { - delete $w->{'updateId'}; - } - unless (defined $folderImage->{$w->MainWindow}) { - require Tk::Pixmap; - $folderImage->{$w->MainWindow} = $w->Pixmap(-file => Tk->findINC('folder.xpm')); - $fileImage->{$w->MainWindow} = $w->Pixmap(-file => Tk->findINC('file.xpm')); - } - my $folder = $folderImage->{$w->MainWindow}; - my $file = $fileImage->{$w->MainWindow}; - my $appPWD = _cwd(); - if (!ext_chdir($w->{'selectPath'})) { - # We cannot change directory to $data(selectPath). $data(selectPath) - # should have been checked before tkFDialog_Update is called, so - # we normally won't come to here. Anyways, give an error and abort - # action. - $w->messageBox(-type => 'OK', - -message => 'Cannot change to the directory "' . - $w->{'selectPath'} . "\".\nPermission denied.", - -icon => 'warning', - ); - ext_chdir($appPWD); - return; - } - - # Turn on the busy cursor. BUG?? We haven't disabled X events, though, - # so the user may still click and cause havoc ... - my $ent = $w->{'ent'}; - my $entCursor = $ent->cget(-cursor); - my $dlgCursor = $w->cget(-cursor); - $ent->configure(-cursor => 'watch'); - $w->configure(-cursor => 'watch'); - $w->idletasks; - my $icons = $w->{'icons'}; - $icons->DeleteAll; - - # Make the dir & file list - my $cwd = _cwd(); - local *FDIR; - if (opendir(FDIR, $cwd)) { - my @files; -# my $sortcmd = $w->cget(-sortcmd); - my $sortcmd = sub { $w->cget(-sortcmd)->($a,$b) }; - my $flt = $w->cget(-filter); - my $fltcb; - if (ref $flt eq 'CODE') { - $fltcb = $flt; - } else { - $flt = _rx_to_glob($flt); - } - my $type_dir = $w->cget(-type) eq 'dir'; - foreach my $f (sort $sortcmd readdir(FDIR)) { - next if $f eq '.' or $f eq '..'; - next if $type_dir && ! -d "$cwd/$f"; # XXX use File::Spec? - if ($fltcb) { - next if !$fltcb->($w, $f, $cwd); - } else { - next if -f $f && $f !~ m!$flt!; - } - if (-d $f) { - $icons->Add($folder, $f); - } else { - push @files, $f; - } - } - closedir(FDIR); - $icons->Add($file, @files); - } - - $icons->Arrange; - - # Update the Directory: option menu - my @list; - my $dir = ''; - foreach my $subdir (TclFileSplit($w->{'selectPath'})) { - $dir = TclFileJoin($dir, $subdir); - push @list, $dir; - } - my $dirMenu = $w->{'dirMenu'}; - $dirMenu->configure(-options => \@list); - - # Restore the PWD to the application's PWD - ext_chdir($appPWD); - - # Restore the Save label - if ($w->cget(-type) eq 'save') { - $w->{'okBtn'}->configure(-text => 'Save'); - } - - # turn off the busy cursor. - $ent->configure(-cursor => $entCursor); - $w->configure(-cursor => $dlgCursor); -} - -# tkFDialog_SetPathSilently -- -# -# Sets data(selectPath) without invoking the trace procedure -# -sub SetPathSilently { - my($w, $path) = @_; - - $w->{'selectPath'} = $path; -} - -# This proc gets called whenever data(selectPath) is set -# -sub SetPath { - my $w = shift; - $w->{'selectPath'} = $_[0] if @_; - $w->UpdateWhenIdle; -} - -# This proc gets called whenever data(filter) is set -# -#XXX here's much more code in the tcl version ... check it out -sub SetFilter { - my($w, $title, $filter) = @_; - $w->configure(-filter => $filter); - $w->{'typeMenuBtn'}->configure(-text => $title, - -indicatoron => 1); - $w->{'icons'}->Subwidget('sbar')->set(0.0, 0.0); - $w->UpdateWhenIdle; -} - -# tkFDialogResolveFile -- -# -# Interpret the user's text input in a file selection dialog. -# Performs: -# -# (1) ~ substitution -# (2) resolve all instances of . and .. -# (3) check for non-existent files/directories -# (4) check for chdir permissions -# -# Arguments: -# context: the current directory you are in -# text: the text entered by the user -# defaultext: the default extension to add to files with no extension -# -# Return value: -# [list $flag $directory $file] -# -# flag = OK : valid input -# = PATTERN : valid directory/pattern -# = PATH : the directory does not exist -# = FILE : the directory exists but the file doesn't -# exist -# = CHDIR : Cannot change to the directory -# = ERROR : Invalid entry -# -# directory : valid only if flag = OK or PATTERN or FILE -# file : valid only if flag = OK or PATTERN -# -# directory may not be the same as context, because text may contain -# a subdirectory name -# -sub ResolveFile { - my($context, $text, $defaultext) = @_; - my $appPWD = _cwd(); - my $path = JoinFile($context, $text); - # If the file has no extension, append the default. Be careful not - # to do this for directories, otherwise typing a dirname in the box - # will give back "dirname.extension" instead of trying to change dir. - if (!-d $path && $path !~ /\..+$/ && defined $defaultext) { - $path = "$path$defaultext"; - } - # Cannot just test for existance here as non-existing files are - # not an error for getSaveFile type dialogs. - # return ('ERROR', $path, "") if (!-e $path); - my($directory, $file, $flag); - if (-e $path) { - if (-d $path) { - if (!ext_chdir($path)) { - return ('CHDIR', $path, ''); - } - $directory = _cwd(); - $file = ''; - $flag = 'OK'; - ext_chdir($appPWD); - } else { - my $dirname = File::Basename::dirname($path); - if (!ext_chdir($dirname)) { - return ('CHDIR', $dirname, ''); - } - $directory = _cwd(); - $file = File::Basename::basename($path); - $flag = 'OK'; - ext_chdir($appPWD); - } - } else { - my $dirname = File::Basename::dirname($path); - if (-e $dirname) { - if (!ext_chdir($dirname)) { - return ('CHDIR', $dirname, ''); - } - $directory = _cwd(); - $file = File::Basename::basename($path); - if ($file =~ /[*?]/) { - $flag = 'PATTERN'; - } else { - $flag = 'FILE'; - } - ext_chdir($appPWD); - } else { - $directory = $dirname; - $file = File::Basename::basename($path); - $flag = 'PATH'; - } - } - return ($flag,$directory,$file); -} - -# Gets called when the entry box gets keyboard focus. We clear the selection -# from the icon list . This way the user can be certain that the input in the -# entry box is the selection. -# -sub EntFocusIn { - my $w = shift; - my $ent = $w->{'ent'}; - if ($ent->get ne '') { - $ent->selectionRange(0, 'end'); - $ent->icursor('end'); - } else { - $ent->selectionClear; - } -#XXX is this missing in the tcl version, too??? $w->{'icons'}->Selection('clear'); - my $okBtn = $w->{'okBtn'}; - if ($w->cget(-type) ne 'save') { - $okBtn->configure(-text => 'Open'); - } else { - $okBtn->configure(-text => 'Save'); - } -} - -sub EntFocusOut { - my $w = shift; - $w->{'ent'}->selectionClear; -} - -# Gets called when user presses Return in the "File name" entry. -# -sub ActivateEnt { - my $w = shift; - my $ent = $w->{'ent'}; - my $text = $ent->get; - if ($w->cget(-multiple)) { - # For the multiple case we have to be careful to get the file - # names as a true list, watching out for a single file with a - # space in the name. Thus we query the IconList directly. - - $w->{'selectFile'} = []; - for my $item ($w->{'icons'}->Curselection) { - $w->VerifyFileName($w->{'icons'}->Get($item)); - } - } else { - $w->VerifyFileName($text); - } -} - -# Verification procedure -# -sub VerifyFileName { - my($w, $text) = @_; -#XXX leave this here? -# $text =~ s/^\s+//; -# $text =~ s/\s+$//; - my($flag, $path, $file) = ResolveFile($w->{'selectPath'}, $text, - $w->cget(-defaultextension)); - my $ent = $w->{'ent'}; - if ($flag eq 'OK') { - if ($file eq '') { - # user has entered an existing (sub)directory - $w->SetPath($path); - $ent->delete(0, 'end'); - } else { - $w->SetPathSilently($path); - if ($w->cget(-multiple)) { - push @{ $w->{'selectFile'} }, $file; - } else { - $w->{'selectFile'} = $file; - } - $w->Done; - } - } elsif ($flag eq 'PATTERN') { - $w->SetPath($path); - $w->configure(-filter => $file); - } elsif ($flag eq 'FILE') { - if ($w->cget(-type) eq 'open') { - $w->messageBox(-icon => 'warning', - -type => 'OK', - -message => 'File "' . TclFileJoin($path, $file) - . '" does not exist.'); - $ent->selectionRange(0, 'end'); - $ent->icursor('end'); - } elsif ($w->cget(-type) eq 'save') { - $w->SetPathSilently($path); - if ($w->cget(-multiple)) { - push @{ $w->{'selectFile'} }, $file; - } else { - $w->{'selectFile'} = $file; - } - $w->Done; - } - } elsif ($flag eq 'PATH') { - $w->messageBox(-icon => 'warning', - -type => 'OK', - -message => "Directory \'$path\' does not exist."); - $ent->selectionRange(0, 'end'); - $ent->icursor('end'); - } elsif ($flag eq 'CHDIR') { - $w->messageBox(-type => 'OK', - -message => "Cannot change to the directory \"$path\".\nPermission denied.", - -icon => 'warning'); - $ent->selectionRange(0, 'end'); - $ent->icursor('end'); - } elsif ($flag eq 'ERROR') { - $w->messageBox(-type => 'OK', - -message => "Invalid file name \"$path\".", - -icon => 'warning'); - $ent->selectionRange(0, 'end'); - $ent->icursor('end'); - } -} - -# Gets called when user presses the Alt-s or Alt-o keys. -# -sub InvokeBtn { - my($w, $key) = @_; - my $okBtn = $w->{'okBtn'}; - $okBtn->invoke if ($okBtn->cget(-text) eq $key); -} - -# Gets called when user presses the "parent directory" button -# -sub UpDirCmd { - my $w = shift; - $w->SetPath(File::Basename::dirname($w->{'selectPath'})) - unless ($w->{'selectPath'} eq '/'); -} - -# Join a file name to a path name. The "file join" command will break -# if the filename begins with ~ -sub JoinFile { - my($path, $file) = @_; - if ($file =~ /^~/ && -e "$path/$file") { - TclFileJoin($path, "./$file"); - } else { - TclFileJoin($path, $file); - } -} - -# XXX replace with File::Spec when perl/Tk depends on 5.005 -sub TclFileJoin { - my $path = ''; - foreach (@_) { - if (m|^/|) { - $path = $_; - } - elsif (m|^[a-z]:/|i) { # DOS-ish - $path = $_; - } elsif ($_ eq '~') { - $path = _get_homedir(); - } elsif (m|^~/(.*)|) { - $path = _get_homedir() . "/" . $1; - } elsif (m|^~([^/]+)(.*)|) { - my($user, $p) = ($1, $2); - my $dir = _get_homedir($user); - if (!defined $dir) { - $path = "~$user$p"; - } else { - $path = $dir . $p; - } - } elsif ($path eq '/' or $path eq '') { - $path .= $_; - } else { - $path .= "/$_"; - } - } - $path; -} - -sub TclFileSplit { - my $path = shift; - my @comp; - $path =~ s|/+|/|g; # strip multiple slashes - if ($path =~ m|^/|) { - push @comp, '/'; - $path = substr($path, 1); - } - push @comp, split /\//, $path; - @comp; -} - -# Gets called when user presses the "OK" button -# -sub OkCmd { - my $w = shift; - my $from = shift || "button"; - - my $filenames = []; - for my $item ($w->{'icons'}->Curselection) { - push @$filenames, $w->{'icons'}->Get($item); - } - - my $filename = $filenames->[0]; - if ($w->cget('-type') eq 'dir' && $from ne "iconlist") { - my $file = $filename eq '' ? $w->{'selectPath'} : JoinFile($w->{'selectPath'}, $filename); - $w->Done($file); - } elsif ((@$filenames && !$w->cget('-multiple')) || - ($w->cget('-multiple') && @$filenames == 1)) { - my $file = JoinFile($w->{'selectPath'}, $filename); - if (-d $file) { - $w->ListInvoke($filename); - return; - } - } - - $w->ActivateEnt; -} - -# Gets called when user presses the "Cancel" button -# -sub CancelCmd { - my $w = shift; - undef $w->{'selectFilePath'}; -} - -# Gets called when user browses the IconList widget (dragging mouse, arrow -# keys, etc) -# -sub ListBrowse { - my($w) = @_; - - my $text = []; - for my $item ($w->{'icons'}->Curselection) { - push @$text, $w->{'icons'}->Get($item); - } - return if @$text == 0; - my $isDir; - if (@$text > 1) { - my $newtext = []; - for my $file (@$text) { - my $fullfile = JoinFile($w->{'selectPath'}, $file); - if (!-d $fullfile) { - push @$newtext, $file; - } - } - $text = $newtext; - $isDir = 0; - } else { - my $file = JoinFile($w->{'selectPath'}, $text->[0]); - $isDir = -d $file; - } - my $ent = $w->{'ent'}; - my $okBtn = $w->{'okBtn'}; - if (!$isDir) { - $ent->delete(qw(0 end)); - $ent->insert(0, "@$text"); # XXX quote! - - if ($w->cget('-type') ne 'save') { - $okBtn->configure(-text => 'Open'); - } else { - $okBtn->configure(-text => 'Save'); - } - } else { - $okBtn->configure(-text => 'Open'); - } -} - -# Gets called when user invokes the IconList widget (double-click, -# Return key, etc) -# -sub ListInvoke { - my($w, @filenames) = @_; - return if !@filenames; - my $file = JoinFile($w->{'selectPath'}, $filenames[0]); - if (-d $file) { - my $appPWD = _cwd(); - if (!ext_chdir($file)) { - $w->messageBox(-type => 'OK', - -message => "Cannot change to the directory \"$file\".\nPermission denied.", - -icon => 'warning'); - } else { - ext_chdir($appPWD); - $w->SetPath($file); - } - } else { - if ($w->cget('-multiple')) { - $w->{'selectFile'} = [@filenames]; - } else { - $w->{'selectFile'} = $file; - } - $w->Done; - } -} - -# tkFDialog_Done -- -# -# Gets called when user has input a valid filename. Pops up a -# dialog box to confirm selection when necessary. Sets the -# tkPriv(selectFilePath) variable, which will break the "tkwait" -# loop in tkFDialog and return the selected filename to the -# script that calls tk_getOpenFile or tk_getSaveFile -# -sub Done { - my $w = shift; - my $selectFilePath = (@_) ? shift : ''; - if ($selectFilePath eq '') { - if ($w->cget('-multiple')) { - $selectFilePath = []; - for my $f (@{ $w->{'selectFile'} }) { - push @$selectFilePath, JoinFile($w->{'selectPath'}, $f); - } - } else { - $selectFilePath = JoinFile($w->{'selectPath'}, - $w->{'selectFile'}); - } - if ($w->cget(-type) eq 'save' and - -e $selectFilePath and - !$w->cget(-force)) { - my $reply = $w->messageBox - (-icon => 'warning', - -type => 'YesNo', - -message => "File \"$selectFilePath\" already exists.\nDo you want to overwrite it?"); - return unless (lc($reply) eq 'yes'); - } - } - $w->{'selectFilePath'} = ($selectFilePath ne '' ? $selectFilePath : undef); -} - -sub FDialog { - my $cmd = shift; - if ($cmd =~ /Save/) { - push @_, -type => 'save'; - } elsif ($cmd =~ /Directory/) { - push @_, -type => 'dir'; - } - Tk::DialogWrapper('FBox', $cmd, @_); -} - -# tkFDGetFileTypes -- -# -# Process the string given by the -filetypes option of the file -# dialogs. Similar to the C function TkGetFileFilters() on the Mac -# and Windows platform. -# -sub GetFileTypes { - my $in = shift; - my %fileTypes; - foreach my $t (@$in) { - if (@$t < 2 || @$t > 3) { - require Carp; - Carp::croak("bad file type \"$t\", should be \"typeName [extension ?extensions ...?] ?[macType ?macTypes ...?]?\""); - } - push @{ $fileTypes{$t->[0]} }, (ref $t->[1] eq 'ARRAY' - ? @{ $t->[1] } - : $t->[1]); - } - - my @types; - my %hasDoneType; - my %hasGotExt; - foreach my $t (@$in) { - my $label = $t->[0]; - my @exts; - - next if (exists $hasDoneType{$label}); - - my $name = "$label ("; - my $sep = ''; - foreach my $ext (@{ $fileTypes{$label} }) { - next if ($ext eq ''); - $ext =~ s/^\./*./; - if (!exists $hasGotExt{$label}->{$ext}) { - $name .= "$sep$ext"; - push @exts, $ext; - $hasGotExt{$label}->{$ext}++; - } - $sep = ','; - } - $name .= ')'; - push @types, [$name, \@exts]; - - $hasDoneType{$label}++; - } - - return @types; -} - -# ext_chdir -- -# -# Change directory with tilde substitution -# -sub ext_chdir { - my $dir = shift; - if ($dir eq '~') { - chdir _get_homedir(); - } elsif ($dir =~ m|^~/(.*)|) { - chdir _get_homedir() . "/" . $1; - } elsif ($dir =~ m|^~([^/]+(.*))|) { - chdir _get_homedir($1) . $2; - } else { - chdir $dir; - } -} - -# _get_homedir -- -# -# Get home directory of the current user -# -sub _get_homedir { - my($user) = @_; - if (!defined $user) { - eval { - local $SIG{__DIE__}; - (getpwuid($<))[7]; - } || $ENV{HOME} || undef; # chdir undef changes to home directory, too - } else { - eval { - local $SIG{__DIE__}; - (getpwnam($user))[7]; - }; - } -} - -sub _cwd { - #Cwd::cwd(); - Cwd::fastcwd(); # this is taint-safe -} - -sub _untaint { - my $s = shift; - $s =~ /^(.*)$/; - $1; -} - -sub _rx_to_glob { - my $arg = shift; - $arg = join('|', split(' ', $arg)); - $arg =~ s!([\.\+])!\\$1!g; - $arg =~ s!\*!.*!g; - $arg = "^" . $arg . "\$"; - if ($] >= 5.005) { - $arg = qr/$arg/; - } - $arg; -} - -1; - |