# Implements the "TK" standard file selection dialog box. This
# dialog box is used on the Unix platforms whenever the tk_strictMotif
# 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 perk/Tk by Slaven Rezic <eserte@cs.tu-berlin.de>.
#----------------------------------------------------------------------
#----------------------------------------------------------------------
# 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.
use vars
qw($VERSION $updirImage $folderImage $fileImage);
$VERSION = '3.019'; # $Id: //depot/Tk8/Tk/FBox.pm#19 $
use base qw(Tk::Toplevel);
Construct Tk
::Widget
'FBox';
if (defined $_[1] and $_[1] eq 'as_default') {
*FDialog
= \
&Tk
::FBox
::FDialog
;
*MotifFDialog
= \
&Tk
::FBox
::FDialog
;
$w->SUPER::Populate
($args);
# f1: the frame with the directory option menu
my $lab = $f1->Label(-text
=> 'Directory:', -underline
=> 0);
$w->{'dirMenu'} = my $dirMenu =
$f1->Optionmenu(-variable
=> \
$w->{'selectPath'},
-command
=> ['SetPath', $w]);
if (!defined $updirImage) {
$updirImage = $w->Bitmap(-data
=> "#define updir_width 28\n" .
"#define updir_height 16\n" .
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,
$upBtn->configure(-image
=> $updirImage);
$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(-browsecmd
=> ['ListBrowse', $w],
-command
=> ['ListInvoke', $w],
# f2: the frame with the OK button and the "file name" field
my $f2 = $w->Frame(-bd
=> 0);
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
# $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
$w->{'typeMenuLab'} = my $typeMenuLab = $f3->Button
(-text
=> 'Files of type:',
-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
),
$typeMenuLab->bindtags([$typeMenuLab, 'Label',
$typeMenuLab->toplevel, 'all']);
$w->{'typeMenuBtn'} = my $typeMenuBtn =
$f3->Menubutton(-indicatoron
=> 1, -tearoff
=> 0);
$typeMenuBtn->configure(-takefocus
=> 1,
-highlightthickness
=> 2,
# the okBtn is created after the typeMenu so that the keyboard traversal
$w->{'okBtn'} = my $okBtn = $f2->Button
my $cancelBtn = $f3->Button
# 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']);
if ($typeMenuBtn->cget(-state) eq 'normal') {
$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_BindIn($ent, ['EntFocusIn', $w]);
$w->FG_BindOut($ent, ['EntFocusOut', $w]);
$w->ConfigSpecs(-defaultextension
=> ['PASSIVE', undef, undef, undef],
-filetypes
=> ['PASSIVE', undef, undef, undef],
-initialdir
=> ['PASSIVE', undef, undef, undef],
-initialfile
=> ['PASSIVE', undef, undef, undef],
-title
=> ['PASSIVE', undef, undef, undef],
-type
=> ['PASSIVE', undef, undef, 'open'],
-filter
=> ['PASSIVE', undef, undef, '*'],
-force
=> ['PASSIVE', undef, undef, 0],
# So-far-failed attempt to break reference loops ...
$w->_OnDestroy(qw(dirMenu icons typeMenuLab typeMenuBtn okBtn ent updateId));
$w->transient($w->Parent);
# set the default directory and selection according to the -initial
my $initialdir = $w->cget(-initialdir
);
if (defined $initialdir) {
$w->{'selectPath'} = $initialdir;
$w->Error("\"$initialdir\" is not a valid directory");
$w->{'selectFile'} = $w->cget(-initialfile
);
# 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 $filter = join(' ', @
{ $ft->[1] });
-command
=> ['SetFilter', $w, $title, $filter],
$w->SetFilter($filetypes[0]->[0], join(' ', @
{ $filetypes[0]->[1] }));
$typeMenuBtn->configure(-state => 'normal');
$typeMenuLab->configure(-state => 'normal');
$w->configure(-filter
=> '*');
$typeMenuBtn->configure(-state => 'disabled',
$typeMenuLab->configure(-state => 'disabled');
# 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.
my $x = int($w->screenwidth / 2 - $w->reqwidth / 2 - $w->parent->vrootx);
my $y = int($w->screenheight / 2 - $w->reqheight / 2 - $w->parent->vrooty);
my $title = $w->cget(-title
);
$title = ($w->cget(-type
) eq 'open' ?
'Open' : 'Save As');
# Set a grab and claim the focus too.
my $oldFocus = $w->focusCurrent;
my $oldGrab = $w->grabCurrent;
my $grabStatus = $oldGrab->grabStatus if ($oldGrab);
$ent->insert(0, $w->{'selectFile'});
$ent->selectionTo('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(\
$selectFilePath);
$oldFocus->focus if $oldFocus;
if (Tk
::Exists
($w)) { # widget still exists
if ($grabStatus eq 'global') {
# 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.
if (exists $w->{'updateId'}) {
$w->{'updateId'} = $w->after('idle', [$w, 'Update']);
# Loads the files and directories into the IconList widget. Also
# sets up the directory option menu for quick access to parent
# 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') {
unless (defined $folderImage) {
$folderImage = $w->Pixmap(-file
=> Tk
->findINC('folder.xpm'));
$fileImage = $w->Pixmap(-file
=> Tk
->findINC('file.xpm'));
my $folder = $folderImage;
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
$w->messageBox(-type
=> 'OK',
-message
=> 'Cannot change to the directory "' .
$w->{'selectPath'} . "\".\nPermission denied.",
# Turn on the busy cursor. BUG?? We haven't disabled X events, though,
# so the user may still click and cause havoc ...
my $entCursor = $ent->cget(-cursor
);
my $dlgCursor = $w->cget(-cursor
);
$ent->configure(-cursor
=> 'watch');
$w->configure(-cursor
=> 'watch');
my $icons = $w->{'icons'};
# Make the dir & file list
my $flt = join('|', split(' ', $w->cget(-filter
)) );
$flt =~ s!([\.\+])!\\$1!g;
if( opendir( FDIR
, _cwd
() )) {
foreach my $f (sort { lc($a) cmp lc($b) } readdir FDIR
) {
next if $f eq '.' or $f eq '..';
if (-d
$f) { $icons->Add($folder, $f); }
elsif( $f =~ m!$flt$! ) { push( @files, $f ); }
foreach my $f ( @files ) { $icons->Add($file, $f); }
# Update the Directory: option menu
foreach my $subdir (TclFileSplit
($w->{'selectPath'})) {
$dir = TclFileJoin
($dir, $subdir);
my $dirMenu = $w->{'dirMenu'};
$dirMenu->configure(-options
=> \
@list);
# Restore the PWD to the application's PWD
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
$w->{'selectPath'} = $path;
# This proc gets called whenever data(selectPath) is set
$w->{'selectPath'} = $_[0] if @_;
# This proc gets called whenever data(filter) is set
my($w, $title, $filter) = @_;
$w->configure(-filter
=> $filter);
$w->{'typeMenuBtn'}->configure(-text
=> $title,
$w->{'icons'}->Subwidget('sbar')->set(0.0, 0.0);
# tkFDialogResolveFile --
# Interpret the user's text input in a file selection dialog.
# (2) resolve all instances of . and ..
# (3) check for non-existent files/directories
# (4) check for chdir permissions
# 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
# [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
# = 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
my($context, $text, $defaultext) = @_;
my $path = JoinFile
($context, $text);
$path = "$path$defaultext" if ($path !~ /\..+$/) and defined $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);
return ('CHDIR', $path, '');
my $dirname = File
::Basename
::dirname
($path);
if (!ext_chdir
($dirname)) {
return ('CHDIR', $dirname, '');
$file = File
::Basename
::basename
($path);
my $dirname = File
::Basename
::dirname
($path);
if (!ext_chdir
($dirname)) {
return ('CHDIR', $dirname, '');
$file = File
::Basename
::basename
($path);
$file = File
::Basename
::basename
($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.
$ent->selectionTo('end');
my $okBtn = $w->{'okBtn'};
if ($w->cget(-type
) eq 'open') {
$okBtn->configure(-text
=> 'Open');
$okBtn->configure(-text
=> 'Save');
$w->{'ent'}->selectionClear;
# Gets called when user presses Return in the "File name" entry.
my($flag, $path, $file) = ResolveFile
($w->{'selectPath'}, $text,
$w->cget(-defaultextension
));
# user has entered an existing (sub)directory
$w->SetPathSilently($path);
$w->{'selectFile'} = $file;
} elsif ($flag eq 'PATTERN') {
$w->configure(-filter
=> $file);
} elsif ($flag eq 'FILE') {
if ($w->cget(-type
) eq 'open') {
$w->messageBox(-icon
=> 'warning',
-message
=> 'File "' . TclFileJoin
($path, $file)
$ent->selection('from', 0);
$ent->selection('to', 'end');
$w->SetPathSilently($path);
$w->{'selectFile'} = $file;
} elsif ($flag eq 'PATH') {
$w->messageBox(-icon
=> 'warning',
-message
=> "Directory \'$path\' does not exist.");
$ent->selection('from', 0);
$ent->selection('to', 'end');
} elsif ($flag eq 'CHDIR') {
$w->messageBox(-type
=> 'OK',
-message
=> "Cannot change to the directory \"$path\".\nPermission denied.",
$ent->selection('from', 0);
$ent->selection('to', 'end');
} elsif ($flag eq 'ERROR') {
$w->messageBox(-type
=> 'OK',
-message
=> "Invalid file name \"$path\".",
$ent->selection('from', 0);
$ent->selection('to', 'end');
# Gets called when user presses the Alt-s or Alt-o keys.
my $okBtn = $w->{'okBtn'};
$okBtn->invoke if ($okBtn->cget(-text
) eq $key);
# Gets called when user presses the "parent directory" button
$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 ~
if ($file =~ /^~/ && -e
"$path/$file") {
TclFileJoin
($path, "./$file");
TclFileJoin
($path, $file);
# XXX replace with File::Spec when perl/Tk depends on 5.005
elsif (m
|^[a
-z
]:/|i
) { # DOS-ish
$path = _get_homedir
() . "/" . $1;
} elsif (m
|^~([^/]+)(.*)|) {
my($user, $p) = ($1, $2);
my $dir = _get_homedir
($user);
} elsif ($path eq '/' or $path eq '') {
$path =~ s
|/+|/|g
; # strip multiple slashes
$path = substr($path, 1);
push @comp, split /\//, $path;
# Gets called when user presses the "OK" button
my $text = $w->{'icons'}->Get;
if (defined $text and $text ne '') {
my $file = JoinFile
($w->{'selectPath'}, $text);
# Gets called when user presses the "Cancel" button
# Gets called when user browses the IconList widget (dragging mouse, arrow
my $file = JoinFile
($w->{'selectPath'}, $text);
my $okBtn = $w->{'okBtn'};
if ($w->cget(-type
) eq 'open') {
$okBtn->configure(-text
=> 'Open');
$okBtn->configure(-text
=> 'Save');
$okBtn->configure(-text
=> 'Open');
# Gets called when user invokes the IconList widget (double-click,
my $file = JoinFile
($w->{'selectPath'}, $text);
$w->messageBox(-type
=> 'OK',
-message
=> "Cannot change to the directory \"$file\".\nPermission denied.",
$w->{'selectFile'} = $file;
# 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
my $_selectFilePath = (@_) ?
shift : '';
if ($_selectFilePath eq '') {
$_selectFilePath = JoinFile
($w->{'selectPath'}, $w->{'selectFile'});
if (-e
$_selectFilePath and
$w->cget(-type
) eq 'save' and
my $reply = $w->messageBox
-message
=> "File \"$_selectFilePath\" already exists.\nDo you want to overwrite it?");
return unless (lc($reply) eq 'yes');
$selectFilePath = ($_selectFilePath ne '' ?
$_selectFilePath : undef);
push @_, -type
=> 'save';
Tk
::DialogWrapper
('FBox', $cmd, @_);
# Process the string given by the -filetypes option of the file
# dialogs. Similar to the C function TkGetFileFilters() on the Mac
if (@
$t < 2 || @
$t > 3) {
Carp
::croak
("bad file type \"$t\", should be \"typeName [extension ?extensions ...?] ?[macType ?macTypes ...?]?\"");
push @
{ $fileTypes{$t->[0]} }, (ref $t->[1] eq 'ARRAY'
next if (exists $hasDoneType{$label});
foreach my $ext (@
{ $fileTypes{$label} }) {
if (!exists $hasGotExt{$label}->{$ext}) {
$hasGotExt{$label}->{$ext}++;
push @types, [$name, \
@exts];
# Change directory with tilde substitution
} elsif ($dir =~ m
|^~/(.*)|) {
chdir _get_homedir
() . "/" . $1;
} elsif ($dir =~ m
|^~([^/]+(.*))|) {
chdir _get_homedir
($1) . $2;
# Get home directory of the current user
} || $ENV{HOME
} || undef; # chdir undef changes to home directory, too
Cwd
::fastcwd
(); # this is taint-safe