summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/FBox.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/FBox.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/FBox.pm1043
1 files changed, 0 insertions, 1043 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/FBox.pm b/Master/tlpkg/tlperl/lib/Tk/FBox.pm
deleted file mode 100644
index fed7501aea4..00000000000
--- a/Master/tlpkg/tlperl/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;
-