projects / OpenSPARC-T2-DV / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial commit of OpenSPARC T2 design and verification files.
[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / FBox.pm
CommitLineData
86530b38
AT		 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
36package Tk::FBox;
37require Tk::Toplevel;
38
39use strict;
40use vars qw($VERSION $updirImage $folderImage $fileImage);
41
42$VERSION = '3.019'; # $Id: //depot/Tk8/Tk/FBox.pm#19 $
43
44use base qw(Tk::Toplevel);
45
46Construct Tk::Widget 'FBox';
47
48my $selectFilePath;
49my $selectFile;
50my $selectPath;
51
52sub 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
61sub 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);
81static 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};
88EOF
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
215sub 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#
323sub 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#
338sub 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#
427sub SetPathSilently {
428 my($w, $path) = @_;
429
430 $w->{'selectPath'} = $path;
431}
432
433# This proc gets called whenever data(selectPath) is set
434#
435sub 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#
443sub 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#
484sub 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#
539sub 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
558sub EntFocusOut {
559 my $w = shift;
560 $w->{'ent'}->selectionClear;
561}
562
563# Gets called when user presses Return in the "File name" entry.
564#
565sub 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#
626sub 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#
634sub 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 ~
642sub 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
652sub 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
681sub 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#
695sub 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#
710sub CancelCmd {
711 undef $selectFilePath;
712}
713
714# Gets called when user browses the IconList widget (dragging mouse, arrow
715# keys, etc)
716#
717sub 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#
739sub 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#
767sub 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
785sub 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#
799sub 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#
846sub 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#
863sub _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
878sub _cwd {
879 #Cwd::cwd();
880 Cwd::fastcwd(); # this is taint-safe
881}
882
883sub _untaint {
884 my $s = shift;
885 $s =~ /^(.*)$/;
886 $1;
887}
888
8891;
890
Full OpenSPARC design & verification tarball including full HDL.