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