/[ascend]/trunk/tcltk98/TK/templates/asctkfbox84.tcl
ViewVC logotype

Annotation of /trunk/tcltk98/TK/templates/asctkfbox84.tcl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 528 - (hide annotations) (download) (as text)
Sat Apr 22 06:07:09 2006 UTC (14 years, 7 months ago) by ben.allan
File MIME type: text/x-tcl
File size: 54775 byte(s)
start of an 84 port.
1 ben.allan 528 # tkfbox.tcl --
2     #
3     # Implements the "TK" standard file selection dialog box. This
4     # dialog box is used on the Unix platforms whenever the tk_strictMotif
5     # flag is not set.
6     #
7     # The "TK" standard file selection dialog box is similar to the
8     # file selection dialog box on Win95(TM). The user can navigate
9     # the directories by clicking on the folder icons or by
10     # selecting the "Directory" option menu. The user can select
11     # files by clicking on the file icons or by entering a filename
12     # in the "Filename:" entry.
13     #
14     # RCS: @(#) $Id: tkfbox.tcl,v 1.38.2.9 2005/11/22 11:00:38 dkf Exp $
15     #
16     # Copyright (c) 1994-1998 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    
22     #----------------------------------------------------------------------
23     #
24     # I C O N L I S T
25     #
26     # This is a pseudo-widget that implements the icon list inside the
27     # ::tk::dialog::file:: dialog box.
28     #
29     #----------------------------------------------------------------------
30    
31     # ::tk::IconList --
32     #
33     # Creates an IconList widget.
34     #
35     proc ::tk::IconList {w args} {
36     IconList_Config $w $args
37     IconList_Create $w
38     }
39    
40     proc ::tk::IconList_Index {w i} {
41     upvar #0 ::tk::$w data
42     upvar #0 ::tk::$w:itemList itemList
43     if {![info exists data(list)]} {set data(list) {}}
44     switch -regexp -- $i {
45     "^-?[0-9]+$" {
46     if { $i < 0 } {
47     set i 0
48     }
49     if { $i >= [llength $data(list)] } {
50     set i [expr {[llength $data(list)] - 1}]
51     }
52     return $i
53     }
54     "^active$" {
55     return $data(index,active)
56     }
57     "^anchor$" {
58     return $data(index,anchor)
59     }
60     "^end$" {
61     return [llength $data(list)]
62     }
63     "@-?[0-9]+,-?[0-9]+" {
64     foreach {x y} [scan $i "@%d,%d"] {
65     break
66     }
67     set item [$data(canvas) find closest $x $y]
68     return [lindex [$data(canvas) itemcget $item -tags] 1]
69     }
70     }
71     }
72    
73     proc ::tk::IconList_Selection {w op args} {
74     upvar ::tk::$w data
75     switch -exact -- $op {
76     "anchor" {
77     if { [llength $args] == 1 } {
78     set data(index,anchor) [tk::IconList_Index $w [lindex $args 0]]
79     } else {
80     return $data(index,anchor)
81     }
82     }
83     "clear" {
84     if { [llength $args] == 2 } {
85     foreach {first last} $args {
86     break
87     }
88     } elseif { [llength $args] == 1 } {
89     set first [set last [lindex $args 0]]
90     } else {
91     error "wrong # args: should be [lindex [info level 0] 0] path\
92     clear first ?last?"
93     }
94     set first [IconList_Index $w $first]
95     set last [IconList_Index $w $last]
96     if { $first > $last } {
97     set tmp $first
98     set first $last
99     set last $tmp
100     }
101     set ind 0
102     foreach item $data(selection) {
103     if { $item >= $first } {
104     set first $ind
105     break
106     }
107     }
108     set ind [expr {[llength $data(selection)] - 1}]
109     for {} {$ind >= 0} {incr ind -1} {
110     set item [lindex $data(selection) $ind]
111     if { $item <= $last } {
112     set last $ind
113     break
114     }
115     }
116    
117     if { $first > $last } {
118     return
119     }
120     set data(selection) [lreplace $data(selection) $first $last]
121     event generate $w <<ListboxSelect>>
122     IconList_DrawSelection $w
123     }
124     "includes" {
125     set index [lsearch -exact $data(selection) [lindex $args 0]]
126     return [expr {$index != -1}]
127     }
128     "set" {
129     if { [llength $args] == 2 } {
130     foreach {first last} $args {
131     break
132     }
133     } elseif { [llength $args] == 1 } {
134     set last [set first [lindex $args 0]]
135     } else {
136     error "wrong # args: should be [lindex [info level 0] 0] path\
137     set first ?last?"
138     }
139    
140     set first [IconList_Index $w $first]
141     set last [IconList_Index $w $last]
142     if { $first > $last } {
143     set tmp $first
144     set first $last
145     set last $tmp
146     }
147     for {set i $first} {$i <= $last} {incr i} {
148     lappend data(selection) $i
149     }
150     set data(selection) [lsort -integer -unique $data(selection)]
151     event generate $w <<ListboxSelect>>
152     IconList_DrawSelection $w
153     }
154     }
155     }
156    
157     proc ::tk::IconList_Curselection {w} {
158     upvar ::tk::$w data
159     return $data(selection)
160     }
161    
162     proc ::tk::IconList_DrawSelection {w} {
163     upvar ::tk::$w data
164     upvar ::tk::$w:itemList itemList
165    
166     $data(canvas) delete selection
167     foreach item $data(selection) {
168     set rTag [lindex [lindex $data(list) $item] 2]
169     foreach {iTag tTag text serial} $itemList($rTag) {
170     break
171     }
172    
173     set bbox [$data(canvas) bbox $tTag]
174     $data(canvas) create rect $bbox -fill \#a0a0ff -outline \#a0a0ff \
175     -tags selection
176     }
177     $data(canvas) lower selection
178     return
179     }
180    
181     proc ::tk::IconList_Get {w item} {
182     upvar ::tk::$w data
183     upvar ::tk::$w:itemList itemList
184     set rTag [lindex [lindex $data(list) $item] 2]
185     foreach {iTag tTag text serial} $itemList($rTag) {
186     break
187     }
188     return $text
189     }
190    
191     # ::tk::IconList_Config --
192     #
193     # Configure the widget variables of IconList, according to the command
194     # line arguments.
195     #
196     proc ::tk::IconList_Config {w argList} {
197    
198     # 1: the configuration specs
199     #
200     set specs {
201     {-command "" "" ""}
202     {-multiple "" "" "0"}
203     }
204    
205     # 2: parse the arguments
206     #
207     tclParseConfigSpec ::tk::$w $specs "" $argList
208     }
209    
210     # ::tk::IconList_Create --
211     #
212     # Creates an IconList widget by assembling a canvas widget and a
213     # scrollbar widget. Sets all the bindings necessary for the IconList's
214     # operations.
215     #
216     proc ::tk::IconList_Create {w} {
217     upvar ::tk::$w data
218    
219     frame $w
220     set data(sbar) [scrollbar $w.sbar -orient horizontal \
221     -highlightthickness 0 -takefocus 0]
222     set data(canvas) [canvas $w.canvas -bd 2 -relief sunken \
223     -width 400 -height 120 -takefocus 1]
224     pack $data(sbar) -side bottom -fill x -padx 2
225     pack $data(canvas) -expand yes -fill both
226    
227     $data(sbar) config -command [list $data(canvas) xview]
228     $data(canvas) config -xscrollcommand [list $data(sbar) set]
229    
230     # Initializes the max icon/text width and height and other variables
231     #
232     set data(maxIW) 1
233     set data(maxIH) 1
234     set data(maxTW) 1
235     set data(maxTH) 1
236     set data(numItems) 0
237     set data(curItem) {}
238     set data(noScroll) 1
239     set data(selection) {}
240     set data(index,anchor) ""
241     set fg [option get $data(canvas) foreground Foreground]
242     if {$fg eq ""} {
243     set data(fill) black
244     } else {
245     set data(fill) $fg
246     }
247    
248     # Creates the event bindings.
249     #
250     bind $data(canvas) <Configure> [list tk::IconList_Arrange $w]
251    
252     bind $data(canvas) <1> [list tk::IconList_Btn1 $w %x %y]
253     bind $data(canvas) <B1-Motion> [list tk::IconList_Motion1 $w %x %y]
254     bind $data(canvas) <B1-Leave> [list tk::IconList_Leave1 $w %x %y]
255     bind $data(canvas) <Control-1> [list tk::IconList_CtrlBtn1 $w %x %y]
256     bind $data(canvas) <Shift-1> [list tk::IconList_ShiftBtn1 $w %x %y]
257     bind $data(canvas) <B1-Enter> [list tk::CancelRepeat]
258     bind $data(canvas) <ButtonRelease-1> [list tk::CancelRepeat]
259     bind $data(canvas) <Double-ButtonRelease-1> \
260     [list tk::IconList_Double1 $w %x %y]
261    
262     bind $data(canvas) <Up> [list tk::IconList_UpDown $w -1]
263     bind $data(canvas) <Down> [list tk::IconList_UpDown $w 1]
264     bind $data(canvas) <Left> [list tk::IconList_LeftRight $w -1]
265     bind $data(canvas) <Right> [list tk::IconList_LeftRight $w 1]
266     bind $data(canvas) <Return> [list tk::IconList_ReturnKey $w]
267     bind $data(canvas) <KeyPress> [list tk::IconList_KeyPress $w %A]
268     bind $data(canvas) <Control-KeyPress> ";"
269     bind $data(canvas) <Alt-KeyPress> ";"
270    
271     bind $data(canvas) <FocusIn> [list tk::IconList_FocusIn $w]
272     bind $data(canvas) <FocusOut> [list tk::IconList_FocusOut $w]
273    
274     return $w
275     }
276    
277     # ::tk::IconList_AutoScan --
278     #
279     # This procedure is invoked when the mouse leaves an entry window
280     # with button 1 down. It scrolls the window up, down, left, or
281     # right, depending on where the mouse left the window, and reschedules
282     # itself as an "after" command so that the window continues to scroll until
283     # the mouse moves back into the window or the mouse button is released.
284     #
285     # Arguments:
286     # w - The IconList window.
287     #
288     proc ::tk::IconList_AutoScan {w} {
289     upvar ::tk::$w data
290     variable ::tk::Priv
291    
292     if {![winfo exists $w]} return
293     set x $Priv(x)
294     set y $Priv(y)
295    
296     if {$data(noScroll)} {
297     return
298     }
299     if {$x >= [winfo width $data(canvas)]} {
300     $data(canvas) xview scroll 1 units
301     } elseif {$x < 0} {
302     $data(canvas) xview scroll -1 units
303     } elseif {$y >= [winfo height $data(canvas)]} {
304     # do nothing
305     } elseif {$y < 0} {
306     # do nothing
307     } else {
308     return
309     }
310    
311     IconList_Motion1 $w $x $y
312     set Priv(afterId) [after 50 [list tk::IconList_AutoScan $w]]
313     }
314    
315     # Deletes all the items inside the canvas subwidget and reset the IconList's
316     # state.
317     #
318     proc ::tk::IconList_DeleteAll {w} {
319     upvar ::tk::$w data
320     upvar ::tk::$w:itemList itemList
321    
322     $data(canvas) delete all
323     catch {unset data(selected)}
324     catch {unset data(rect)}
325     catch {unset data(list)}
326     catch {unset itemList}
327     set data(maxIW) 1
328     set data(maxIH) 1
329     set data(maxTW) 1
330     set data(maxTH) 1
331     set data(numItems) 0
332     set data(curItem) {}
333     set data(noScroll) 1
334     set data(selection) {}
335     set data(index,anchor) ""
336     $data(sbar) set 0.0 1.0
337     $data(canvas) xview moveto 0
338     }
339    
340     ##
341     # looks up special cases for icons. baa
342     proc ::tk::CustomImage {img f} {
343     set a4c $Priv(a4cImage);
344     set a4l $Priv(a4lImage);
345     set a4s $Priv(a4sImage);
346     set a4o $Priv(a4oImage);
347     set dotc $Priv(dotcImage);
348     set doth $Priv(dothImage);
349     set dotcc $Priv(dotccImage);
350    
351     if {![file isdir ./$f]} {
352     # baa: check for known extensions. this should be more general.
353     if {"[file extension $f]" != ""} {
354     switch [file extension $f] {
355     .CC -
356     .C -
357     .HH -
358     .H -
359     .hxx -
360     .cxx -
361     .hpp -
362     .cpp -
363     .cc {
364     return $dotcc
365     }
366     .c {
367     return $dotc
368     }
369     .h {
370     return $doth
371     }
372     .a4u -
373     .a4o {
374     return $a4o
375     }
376     .asc -
377     .a4c {
378     return $a4c
379     }
380     .a4l {
381     return $a4l
382     }
383     .a4s {
384     return $a4s
385     }
386     default
387     {
388     return $img
389     }
390     }
391     } else {
392     return $img
393     }
394     }
395     return $img
396    
397     }
398     # Adds an icon into the IconList with the designated image and text
399     #
400     proc ::tk::IconList_Add {w image items} {
401     upvar ::tk::$w data
402     upvar ::tk::$w:itemList itemList
403     upvar ::tk::$w:textList textList
404    
405     set image0 $image
406     foreach text $items {
407     set image [::tk:CustomImage image0 $text]
408     set iTag [$data(canvas) create image 0 0 -image $image -anchor nw \
409     -tags [list icon $data(numItems) item$data(numItems)]]
410     set tTag [$data(canvas) create text 0 0 -text $text -anchor nw \
411     -font $data(font) -fill $data(fill) \
412     -tags [list text $data(numItems) item$data(numItems)]]
413     set rTag [$data(canvas) create rect 0 0 0 0 -fill "" -outline "" \
414     -tags [list rect $data(numItems) item$data(numItems)]]
415    
416     foreach {x1 y1 x2 y2} [$data(canvas) bbox $iTag] {
417     break
418     }
419     set iW [expr {$x2 - $x1}]
420     set iH [expr {$y2 - $y1}]
421     if {$data(maxIW) < $iW} {
422     set data(maxIW) $iW
423     }
424     if {$data(maxIH) < $iH} {
425     set data(maxIH) $iH
426     }
427    
428     foreach {x1 y1 x2 y2} [$data(canvas) bbox $tTag] {
429     break
430     }
431     set tW [expr {$x2 - $x1}]
432     set tH [expr {$y2 - $y1}]
433     if {$data(maxTW) < $tW} {
434     set data(maxTW) $tW
435     }
436     if {$data(maxTH) < $tH} {
437     set data(maxTH) $tH
438     }
439    
440     lappend data(list) [list $iTag $tTag $rTag $iW $iH $tW \
441     $tH $data(numItems)]
442     set itemList($rTag) [list $iTag $tTag $text $data(numItems)]
443     set textList($data(numItems)) [string tolower $text]
444     incr data(numItems)
445     }
446     }
447    
448     # Places the icons in a column-major arrangement.
449     #
450     proc ::tk::IconList_Arrange {w} {
451     upvar ::tk::$w data
452    
453     if {![info exists data(list)]} {
454     if {[info exists data(canvas)] && [winfo exists $data(canvas)]} {
455     set data(noScroll) 1
456     $data(sbar) config -command ""
457     }
458     return
459     }
460    
461     set W [winfo width $data(canvas)]
462     set H [winfo height $data(canvas)]
463     set pad [expr {[$data(canvas) cget -highlightthickness] + \
464     [$data(canvas) cget -bd]}]
465     if {$pad < 2} {
466     set pad 2
467     }
468    
469     incr W -[expr {$pad*2}]
470     incr H -[expr {$pad*2}]
471    
472     set dx [expr {$data(maxIW) + $data(maxTW) + 8}]
473     if {$data(maxTH) > $data(maxIH)} {
474     set dy $data(maxTH)
475     } else {
476     set dy $data(maxIH)
477     }
478     incr dy 2
479     set shift [expr {$data(maxIW) + 4}]
480    
481     set x [expr {$pad * 2}]
482     set y [expr {$pad * 1}] ; # Why * 1 ?
483     set usedColumn 0
484     foreach sublist $data(list) {
485     set usedColumn 1
486     foreach {iTag tTag rTag iW iH tW tH} $sublist {
487     break
488     }
489    
490     set i_dy [expr {($dy - $iH)/2}]
491     set t_dy [expr {($dy - $tH)/2}]
492    
493     $data(canvas) coords $iTag $x [expr {$y + $i_dy}]
494     $data(canvas) coords $tTag [expr {$x + $shift}] [expr {$y + $t_dy}]
495     $data(canvas) coords $rTag $x $y [expr {$x+$dx}] [expr {$y+$dy}]
496    
497     incr y $dy
498     if {($y + $dy) > $H} {
499     set y [expr {$pad * 1}] ; # *1 ?
500     incr x $dx
501     set usedColumn 0
502     }
503     }
504    
505     if {$usedColumn} {
506     set sW [expr {$x + $dx}]
507     } else {
508     set sW $x
509     }
510    
511     if {$sW < $W} {
512     $data(canvas) config -scrollregion [list $pad $pad $sW $H]
513     $data(sbar) config -command ""
514     $data(canvas) xview moveto 0
515     set data(noScroll) 1
516     } else {
517     $data(canvas) config -scrollregion [list $pad $pad $sW $H]
518     $data(sbar) config -command [list $data(canvas) xview]
519     set data(noScroll) 0
520     }
521    
522     set data(itemsPerColumn) [expr {($H-$pad)/$dy}]
523     if {$data(itemsPerColumn) < 1} {
524     set data(itemsPerColumn) 1
525     }
526    
527     if {$data(curItem) != ""} {
528     IconList_Select $w [lindex [lindex $data(list) $data(curItem)] 2] 0
529     }
530     }
531    
532     # Gets called when the user invokes the IconList (usually by double-clicking
533     # or pressing the Return key).
534     #
535     proc ::tk::IconList_Invoke {w} {
536     upvar ::tk::$w data
537    
538     if {$data(-command) != "" && [llength $data(selection)]} {
539     uplevel #0 $data(-command)
540     }
541     }
542    
543     # ::tk::IconList_See --
544     #
545     # If the item is not (completely) visible, scroll the canvas so that
546     # it becomes visible.
547     proc ::tk::IconList_See {w rTag} {
548     upvar ::tk::$w data
549     upvar ::tk::$w:itemList itemList
550    
551     if {$data(noScroll)} {
552     return
553     }
554     set sRegion [$data(canvas) cget -scrollregion]
555     if {[string equal $sRegion {}]} {
556     return
557     }
558    
559     if { $rTag < 0 || $rTag >= [llength $data(list)] } {
560     return
561     }
562    
563     set bbox [$data(canvas) bbox item$rTag]
564     set pad [expr {[$data(canvas) cget -highlightthickness] + \
565     [$data(canvas) cget -bd]}]
566    
567     set x1 [lindex $bbox 0]
568     set x2 [lindex $bbox 2]
569     incr x1 -[expr {$pad * 2}]
570     incr x2 -[expr {$pad * 1}] ; # *1 ?
571    
572     set cW [expr {[winfo width $data(canvas)] - $pad*2}]
573    
574     set scrollW [expr {[lindex $sRegion 2]-[lindex $sRegion 0]+1}]
575     set dispX [expr {int([lindex [$data(canvas) xview] 0]*$scrollW)}]
576     set oldDispX $dispX
577    
578     # check if out of the right edge
579     #
580     if {($x2 - $dispX) >= $cW} {
581     set dispX [expr {$x2 - $cW}]
582     }
583     # check if out of the left edge
584     #
585     if {($x1 - $dispX) < 0} {
586     set dispX $x1
587     }
588    
589     if {$oldDispX != $dispX} {
590     set fraction [expr {double($dispX)/double($scrollW)}]
591     $data(canvas) xview moveto $fraction
592     }
593     }
594    
595     proc ::tk::IconList_Btn1 {w x y} {
596     upvar ::tk::$w data
597    
598     focus $data(canvas)
599     set x [expr {int([$data(canvas) canvasx $x])}]
600     set y [expr {int([$data(canvas) canvasy $y])}]
601     set i [IconList_Index $w @${x},${y}]
602     if {$i==""} return
603     IconList_Selection $w clear 0 end
604     IconList_Selection $w set $i
605     IconList_Selection $w anchor $i
606     }
607    
608     proc ::tk::IconList_CtrlBtn1 {w x y} {
609     upvar ::tk::$w data
610    
611     if { $data(-multiple) } {
612     focus $data(canvas)
613     set x [expr {int([$data(canvas) canvasx $x])}]
614     set y [expr {int([$data(canvas) canvasy $y])}]
615     set i [IconList_Index $w @${x},${y}]
616     if {$i==""} return
617     if { [IconList_Selection $w includes $i] } {
618     IconList_Selection $w clear $i
619     } else {
620     IconList_Selection $w set $i
621     IconList_Selection $w anchor $i
622     }
623     }
624     }
625    
626     proc ::tk::IconList_ShiftBtn1 {w x y} {
627     upvar ::tk::$w data
628    
629     if { $data(-multiple) } {
630     focus $data(canvas)
631     set x [expr {int([$data(canvas) canvasx $x])}]
632     set y [expr {int([$data(canvas) canvasy $y])}]
633     set i [IconList_Index $w @${x},${y}]
634     if {$i==""} return
635     set a [IconList_Index $w anchor]
636     if { [string equal $a ""] } {
637     set a $i
638     }
639     IconList_Selection $w clear 0 end
640     IconList_Selection $w set $a $i
641     }
642     }
643    
644     # Gets called on button-1 motions
645     #
646     proc ::tk::IconList_Motion1 {w x y} {
647     upvar ::tk::$w data
648     variable ::tk::Priv
649     set Priv(x) $x
650     set Priv(y) $y
651     set x [expr {int([$data(canvas) canvasx $x])}]
652     set y [expr {int([$data(canvas) canvasy $y])}]
653     set i [IconList_Index $w @${x},${y}]
654     if {$i==""} return
655     IconList_Selection $w clear 0 end
656     IconList_Selection $w set $i
657     }
658    
659     proc ::tk::IconList_Double1 {w x y} {
660     upvar ::tk::$w data
661    
662     if {[llength $data(selection)]} {
663     IconList_Invoke $w
664     }
665     }
666    
667     proc ::tk::IconList_ReturnKey {w} {
668     IconList_Invoke $w
669     }
670    
671     proc ::tk::IconList_Leave1 {w x y} {
672     variable ::tk::Priv
673    
674     set Priv(x) $x
675     set Priv(y) $y
676     IconList_AutoScan $w
677     }
678    
679     proc ::tk::IconList_FocusIn {w} {
680     upvar ::tk::$w data
681    
682     if {![info exists data(list)]} {
683     return
684     }
685    
686     if {[llength $data(selection)]} {
687     IconList_DrawSelection $w
688     }
689     }
690    
691     proc ::tk::IconList_FocusOut {w} {
692     IconList_Selection $w clear 0 end
693     }
694    
695     # ::tk::IconList_UpDown --
696     #
697     # Moves the active element up or down by one element
698     #
699     # Arguments:
700     # w - The IconList widget.
701     # amount - +1 to move down one item, -1 to move back one item.
702     #
703     proc ::tk::IconList_UpDown {w amount} {
704     upvar ::tk::$w data
705    
706     if {![info exists data(list)]} {
707     return
708     }
709    
710     set curr [tk::IconList_Curselection $w]
711     if { [llength $curr] == 0 } {
712     set i 0
713     } else {
714     set i [tk::IconList_Index $w anchor]
715     if {$i==""} return
716     incr i $amount
717     }
718     IconList_Selection $w clear 0 end
719     IconList_Selection $w set $i
720     IconList_Selection $w anchor $i
721     IconList_See $w $i
722     }
723    
724     # ::tk::IconList_LeftRight --
725     #
726     # Moves the active element left or right by one column
727     #
728     # Arguments:
729     # w - The IconList widget.
730     # amount - +1 to move right one column, -1 to move left one column.
731     #
732     proc ::tk::IconList_LeftRight {w amount} {
733     upvar ::tk::$w data
734    
735     if {![info exists data(list)]} {
736     return
737     }
738    
739     set curr [IconList_Curselection $w]
740     if { [llength $curr] == 0 } {
741     set i 0
742     } else {
743     set i [IconList_Index $w anchor]
744     if {$i==""} return
745     incr i [expr {$amount*$data(itemsPerColumn)}]
746     }
747     IconList_Selection $w clear 0 end
748     IconList_Selection $w set $i
749     IconList_Selection $w anchor $i
750     IconList_See $w $i
751     }
752    
753     #----------------------------------------------------------------------
754     # Accelerator key bindings
755     #----------------------------------------------------------------------
756    
757     # ::tk::IconList_KeyPress --
758     #
759     # Gets called when user enters an arbitrary key in the listbox.
760     #
761     proc ::tk::IconList_KeyPress {w key} {
762     variable ::tk::Priv
763    
764     append Priv(ILAccel,$w) $key
765     IconList_Goto $w $Priv(ILAccel,$w)
766     catch {
767     after cancel $Priv(ILAccel,$w,afterId)
768     }
769     set Priv(ILAccel,$w,afterId) [after 500 [list tk::IconList_Reset $w]]
770     }
771    
772     proc ::tk::IconList_Goto {w text} {
773     upvar ::tk::$w data
774     upvar ::tk::$w:textList textList
775    
776     if {![info exists data(list)]} {
777     return
778     }
779    
780     if {[string equal {} $text]} {
781     return
782     }
783    
784     if {$data(curItem) == "" || $data(curItem) == 0} {
785     set start 0
786     } else {
787     set start $data(curItem)
788     }
789    
790     set text [string tolower $text]
791     set theIndex -1
792     set less 0
793     set len [string length $text]
794     set len0 [expr {$len-1}]
795     set i $start
796    
797     # Search forward until we find a filename whose prefix is an exact match
798     # with $text
799     while {1} {
800     set sub [string range $textList($i) 0 $len0]
801     if {[string equal $text $sub]} {
802     set theIndex $i
803     break
804     }
805     incr i
806     if {$i == $data(numItems)} {
807     set i 0
808     }
809     if {$i == $start} {
810     break
811     }
812     }
813    
814     if {$theIndex > -1} {
815     IconList_Selection $w clear 0 end
816     IconList_Selection $w set $theIndex
817     IconList_Selection $w anchor $theIndex
818     IconList_See $w $theIndex
819     }
820     }
821    
822     proc ::tk::IconList_Reset {w} {
823     variable ::tk::Priv
824    
825     catch {unset Priv(ILAccel,$w)}
826     }
827    
828     #----------------------------------------------------------------------
829     #
830     # F I L E D I A L O G
831     #
832     #----------------------------------------------------------------------
833    
834     namespace eval ::tk::dialog {}
835     namespace eval ::tk::dialog::file {
836     namespace import -force ::tk::msgcat::*
837     set ::tk::dialog::file::showHiddenBtn 0
838     set ::tk::dialog::file::showHiddenVar 1
839     }
840    
841     # ::tk::dialog::file:: --
842     #
843     # Implements the TK file selection dialog. This dialog is used when
844     # the tk_strictMotif flag is set to false. This procedure shouldn't
845     # be called directly. Call tk_getOpenFile or tk_getSaveFile instead.
846     #
847     # Arguments:
848     # type "open" or "save"
849     # args Options parsed by the procedure.
850     #
851    
852     proc ::tk::dialog::file:: {type args} {
853     variable ::tk::Priv
854     global asc_tkfbox; #baa
855    
856     set dataName __tk_filedialog
857     upvar ::tk::dialog::file::$dataName data
858    
859     ::tk::dialog::file::Config $dataName $type $args
860    
861     if {[string equal $data(-parent) .]} {
862     set w .$dataName
863     } else {
864     set w $data(-parent).$dataName
865     }
866    
867     # (re)create the dialog box if necessary
868     #
869     if {![winfo exists $w]} {
870     ::tk::dialog::file::Create $w TkFDialog
871     } elseif {[winfo class $w] ne "TkFDialog"} {
872     destroy $w
873     ::tk::dialog::file::Create $w TkFDialog
874     } else {
875     set data(dirMenuBtn) $w.f1.menu
876     set data(dirMenu) $w.f1.menu.menu
877     set data(upBtn) $w.f1.up
878     set data(icons) $w.icons
879     set data(ent) $w.f2.ent
880     set data(typeMenuLab) $w.f2.lab2
881     set data(typeMenuBtn) $w.f2.menu
882     set data(typeMenu) $data(typeMenuBtn).m
883     set data(okBtn) $w.f2.ok
884     set data(cancelBtn) $w.f2.cancel
885     set data(hiddenBtn) $w.f2.hidden
886     ::tk::dialog::file::SetSelectMode $w $data(-multiple)
887     }
888     if {$::tk::dialog::file::showHiddenBtn} {
889     $data(hiddenBtn) configure -state normal
890     grid $data(hiddenBtn)
891     } else {
892     $data(hiddenBtn) configure -state disabled
893     grid remove $data(hiddenBtn)
894     }
895    
896     # Make sure subseqent uses of this dialog are independent [Bug 845189]
897     catch {unset data(extUsed)}
898    
899     # Dialog boxes should be transient with respect to their parent,
900     # so that they will always stay on top of their parent window. However,
901     # some window managers will create the window as withdrawn if the parent
902     # window is withdrawn or iconified. Combined with the grab we put on the
903     # window, this can hang the entire application. Therefore we only make
904     # the dialog transient if the parent is viewable.
905    
906     if {[winfo viewable [winfo toplevel $data(-parent)]]} {
907     wm transient $w $data(-parent)
908     }
909    
910     # Add traces on the selectPath variable
911     #
912    
913     trace variable data(selectPath) w [list ::tk::dialog::file::SetPath $w]
914     $data(dirMenuBtn) configure \
915     -textvariable ::tk::dialog::file::${dataName}(selectPath)
916    
917     # Initialize the file types menu
918     #
919     if {[llength $data(-filetypes)]} {
920     $data(typeMenu) delete 0 end
921     foreach type $data(-filetypes) {
922     set title [lindex $type 0]
923     set filter [lindex $type 1]
924     $data(typeMenu) add command -label $title \
925     -command [list ::tk::dialog::file::SetFilter $w $type]
926     }
927     ::tk::dialog::file::SetFilter $w [lindex $data(-filetypes) 0]
928     $data(typeMenuBtn) config -state normal
929     $data(typeMenuLab) config -state normal
930     } else {
931     set data(filter) "*"
932     $data(typeMenuBtn) config -state disabled -takefocus 0
933     $data(typeMenuLab) config -state disabled
934     }
935     ::tk::dialog::file::UpdateWhenIdle $w
936    
937     # Withdraw the window, then update all the geometry information
938     # so we know how big it wants to be, then center the window in the
939     # display and de-iconify it.
940     catch {unset asc_tkfbox(givendir)} quiet; # baa
941     set asc_tkfbox(cancelled) 0; # baa
942    
943     ::tk::PlaceWindow $w widget $data(-parent)
944     wm title $w $data(-title)
945    
946     # Set a grab and claim the focus too.
947    
948     ::tk::SetFocusGrab $w $data(ent)
949     $data(ent) delete 0 end
950     $data(ent) insert 0 $data(selectFile)
951     $data(ent) selection range 0 end
952     $data(ent) icursor end
953    
954     # Wait for the user to respond, then restore the focus and
955     # return the index of the selected button. Restore the focus
956     # before deleting the window, since otherwise the window manager
957     # may take the focus away so we can't redirect it. Finally,
958     # restore any grab that was in effect.
959    
960     vwait ::tk::Priv(selectFilePath)
961    
962     ::tk::RestoreFocusGrab $w $data(ent) withdraw
963    
964     # Cleanup traces on selectPath variable
965     #
966    
967     foreach trace [trace vinfo data(selectPath)] {
968     trace vdelete data(selectPath) [lindex $trace 0] [lindex $trace 1]
969     }
970     $data(dirMenuBtn) configure -textvariable {}
971    
972     return $Priv(selectFilePath)
973     }
974    
975     # ::tk::dialog::file::Config --
976     #
977     # Configures the TK filedialog according to the argument list
978     #
979     proc ::tk::dialog::file::Config {dataName type argList} {
980     upvar ::tk::dialog::file::$dataName data
981    
982     set data(type) $type
983    
984     # 0: Delete all variable that were set on data(selectPath) the
985     # last time the file dialog is used. The traces may cause troubles
986     # if the dialog is now used with a different -parent option.
987    
988     foreach trace [trace vinfo data(selectPath)] {
989     trace vdelete data(selectPath) [lindex $trace 0] [lindex $trace 1]
990     }
991    
992     # 1: the configuration specs
993     #
994     set specs {
995     {-defaultextension "" "" ""}
996     {-filetypes "" "" ""}
997     {-initialdir "" "" ""}
998     {-initialfile "" "" ""}
999     {-parent "" "" "."}
1000     {-title "" "" ""}
1001     }
1002    
1003     # The "-multiple" option is only available for the "open" file dialog.
1004     #
1005     if { [string equal $type "open"] } {
1006     lappend specs {-multiple "" "" "0"}
1007     }
1008    
1009     # 2: default values depending on the type of the dialog
1010     #
1011     if {![info exists data(selectPath)]} {
1012     # first time the dialog has been popped up
1013     set data(selectPath) [pwd]
1014     set data(selectFile) ""
1015     }
1016    
1017     # 3: parse the arguments
1018     #
1019     tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList
1020    
1021     if {$data(-title) == ""} {
1022     if {[string equal $type "open"]} {
1023     set data(-title) "[mc "Open"]"
1024     } else {
1025     set data(-title) "[mc "Save As"]"
1026     }
1027     }
1028    
1029     # 4: set the default directory and selection according to the -initial
1030     # settings
1031     #
1032     if {$data(-initialdir) != ""} {
1033     # Ensure that initialdir is an absolute path name.
1034     if {[file isdirectory $data(-initialdir)]} {
1035     set old [pwd]
1036     cd $data(-initialdir)
1037     set data(selectPath) [pwd]
1038     cd $old
1039     } else {
1040     set data(selectPath) [pwd]
1041     }
1042     }
1043     set data(selectFile) $data(-initialfile)
1044    
1045     # 5. Parse the -filetypes option
1046     #
1047     set data(-filetypes) [::tk::FDGetFileTypes $data(-filetypes)]
1048    
1049     if {![winfo exists $data(-parent)]} {
1050     error "bad window path name \"$data(-parent)\""
1051     }
1052    
1053     # Set -multiple to a one or zero value (not other boolean types
1054     # like "yes") so we can use it in tests more easily.
1055     if {![string compare $type save]} {
1056     set data(-multiple) 0
1057     } elseif {$data(-multiple)} {
1058     set data(-multiple) 1
1059     } else {
1060     set data(-multiple) 0
1061     }
1062     }
1063    
1064     proc ::tk::dialog::file::Create {w class} {
1065     set dataName [lindex [split $w .] end]
1066     upvar ::tk::dialog::file::$dataName data
1067     variable ::tk::Priv
1068     global tk_library
1069    
1070     toplevel $w -class $class
1071    
1072     # f1: the frame with the directory option menu
1073     #
1074     set f1 [frame $w.f1]
1075     label $f1.lock -bitmap grablock -under 0 ; # baa
1076     bind [::tk::AmpWidget label $f1.lab -text "[mc "&Directory:"]" ] \
1077     <<AltUnderlined>> [list focus $f1.menu]
1078    
1079     set data(dirMenuBtn) $f1.menu
1080     set data(dirMenu) [tk_optionMenu $f1.menu [format %s(selectPath) ::tk::dialog::file::$dataName] ""]
1081     set data(upBtn) [button $f1.up]
1082     if {![info exists Priv(updirImage)]} {
1083     set Priv(updirImage) [image create bitmap -data {
1084     #define updir_width 28
1085     #define updir_height 16
1086     static char updir_bits[] = {
1087     0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1088     0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1089     0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1090     0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1091     0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1092     0xf0, 0xff, 0xff, 0x01};}]
1093     }
1094     $data(upBtn) config -image $Priv(updirImage)
1095    
1096     $f1.menu config -takefocus 1 -highlightthickness 2
1097    
1098     pack $data(upBtn) -side right -padx 4 -fill both
1099     pack $f1.lock -side left -padx 4 -fill both
1100     pack $f1.lab -side left -padx 4 -fill both
1101     pack $f1.menu -expand yes -fill both -padx 4
1102    
1103     # data(icons): the IconList that list the files and directories.
1104     #
1105     if { [string equal $class TkFDialog] } {
1106     if { $data(-multiple) } {
1107     set fNameCaption [mc "File &names:"]
1108     } else {
1109     set fNameCaption [mc "File &name:"]
1110     }
1111     set fTypeCaption [mc "Files of &type:"]
1112     set iconListCommand [list ::tk::dialog::file::OkCmd $w]
1113     } else {
1114     set fNameCaption [mc "&Selection:"]
1115     set iconListCommand [list ::tk::dialog::file::chooseDir::DblClick $w]
1116     }
1117     set data(icons) [::tk::IconList $w.icons \
1118     -command $iconListCommand \
1119     -multiple $data(-multiple)]
1120     bind $data(icons) <<ListboxSelect>> \
1121     [list ::tk::dialog::file::ListBrowse $w]
1122    
1123     # f2: the frame with the OK button, cancel button, "file name" field
1124     # and file types field.
1125     #
1126     set f2 [frame $w.f2 -bd 0]
1127     bind [::tk::AmpWidget label $f2.lab -text $fNameCaption -anchor e -pady 0]\
1128     <<AltUnderlined>> [list focus $f2.ent]
1129     set data(ent) [entry $f2.ent]
1130    
1131     # The font to use for the icons. The default Canvas font on Unix
1132     # is just deviant.
1133     set ::tk::$w.icons(font) [$data(ent) cget -font]
1134    
1135     # Make the file types bits only if this is a File Dialog
1136     if { [string equal $class TkFDialog] } {
1137     set data(typeMenuLab) [::tk::AmpWidget label $f2.lab2 \
1138     -text $fTypeCaption -anchor e -pady [$f2.lab cget -pady]]
1139     set data(typeMenuBtn) [menubutton $f2.menu -indicatoron 1 \
1140     -menu $f2.menu.m]
1141     set data(typeMenu) [menu $data(typeMenuBtn).m -tearoff 0]
1142     $data(typeMenuBtn) config -takefocus 1 -highlightthickness 2 \
1143     -relief raised -bd 2 -anchor w
1144     bind $data(typeMenuLab) <<AltUnderlined>> [list \
1145     focus $data(typeMenuBtn)]
1146     }
1147    
1148     # The hidden button is displayed when ::tk::dialog::file::showHiddenBtn
1149     # is true. Create it disabled so the binding doesn't trigger if it
1150     # isn't shown.
1151     if {$class eq "TkFDialog"} {
1152     set text [mc "Show &Hidden Files and Directories"]
1153     } else {
1154     set text [mc "Show &Hidden Directories"]
1155     }
1156     set data(hiddenBtn) [::tk::AmpWidget checkbutton $f2.hidden \
1157     -text $text -anchor w -padx 3 -state disabled \
1158     -variable ::tk::dialog::file::showHiddenVar \
1159     -command [list ::tk::dialog::file::UpdateWhenIdle $w]]
1160    
1161     # the okBtn is created after the typeMenu so that the keyboard traversal
1162     # is in the right order, and add binding so that we find out when the
1163     # dialog is destroyed by the user (added here instead of to the overall
1164     # window so no confusion about how much <Destroy> gets called; exactly
1165     # once will do). [Bug 987169]
1166    
1167     set data(okBtn) [::tk::AmpWidget button $f2.ok \
1168     -text [mc "&OK"] -default active -pady 3]
1169     bind $data(okBtn) <Destroy> [list ::tk::dialog::file::Destroyed $w]
1170     set data(cancelBtn) [::tk::AmpWidget button $f2.cancel \
1171     -text [mc "&Cancel"] -default normal -pady 3]
1172    
1173     # grid the widgets in f2
1174     #
1175     grid $f2.lab $f2.ent $data(okBtn) -padx 4 -sticky ew
1176     grid configure $f2.ent -padx 2
1177     if { [string equal $class TkFDialog] } {
1178     grid $data(typeMenuLab) $data(typeMenuBtn) $data(cancelBtn) \
1179     -padx 4 -sticky ew
1180     grid configure $data(typeMenuBtn) -padx 0
1181     grid $data(hiddenBtn) -columnspan 2 -padx 4 -sticky ew
1182     } else {
1183     grid $data(hiddenBtn) - $data(cancelBtn) -padx 4 -sticky ew
1184     }
1185     grid columnconfigure $f2 1 -weight 1
1186    
1187     # Pack all the frames together. We are done with widget construction.
1188     #
1189     pack $f1 -side top -fill x -pady 4
1190     pack $f2 -side bottom -fill x
1191     pack $data(icons) -expand yes -fill both -padx 4 -pady 1
1192    
1193     # Set up the event handlers that are common to Directory and File Dialogs
1194     #
1195    
1196     wm protocol $w WM_DELETE_WINDOW [list ::tk::dialog::file::CancelCmd $w]
1197     $data(upBtn) config -command [list ::tk::dialog::file::UpDirCmd $w]
1198     $data(cancelBtn) config -command [list ::tk::dialog::file::CancelCmd $w]
1199     bind $w <KeyPress-Escape> [list tk::ButtonInvoke $data(cancelBtn)]
1200     bind $w <Alt-Key> [list tk::AltKeyInDialog $w %A]
1201    
1202     # Set up event handlers specific to File or Directory Dialogs
1203     #
1204     if { [string equal $class TkFDialog] } {
1205     bind $data(ent) <Return> [list ::tk::dialog::file::ActivateEnt $w]
1206     $data(okBtn) config -command [list ::tk::dialog::file::OkCmd $w]
1207     bind $w <Alt-t> [format {
1208     if {[string equal [%s cget -state] "normal"]} {
1209     focus %s
1210     }
1211     } $data(typeMenuBtn) $data(typeMenuBtn)]
1212     } else {
1213     set okCmd [list ::tk::dialog::file::chooseDir::OkCmd $w]
1214     bind $data(ent) <Return> $okCmd
1215     $data(okBtn) config -command $okCmd
1216     bind $w <Alt-s> [list focus $data(ent)]
1217     bind $w <Alt-o> [list tk::ButtonInvoke $data(okBtn)]
1218     }
1219     bind $w <Alt-h> [list $data(hiddenBtn) invoke]
1220    
1221     # Build the focus group for all the entries
1222     #
1223     ::tk::FocusGroup_Create $w
1224     ::tk::FocusGroup_BindIn $w $data(ent) [list ::tk::dialog::file::EntFocusIn $w]
1225     ::tk::FocusGroup_BindOut $w $data(ent) [list ::tk::dialog::file::EntFocusOut $w]
1226    
1227     # hack to keep the filebox on top baa 6/97
1228     bind $w <Visibility> "ascKeepOnTop $w"; # baa
1229     }
1230    
1231     # ::tk::dialog::file::SetSelectMode --
1232     #
1233     # Set the select mode of the dialog to single select or multi-select.
1234     #
1235     # Arguments:
1236     # w The dialog path.
1237     # multi 1 if the dialog is multi-select; 0 otherwise.
1238     #
1239     # Results:
1240     # None.
1241    
1242     proc ::tk::dialog::file::SetSelectMode {w multi} {
1243     set dataName __tk_filedialog
1244     upvar ::tk::dialog::file::$dataName data
1245     if { $multi } {
1246     set fNameCaption "[mc {File &names:}]"
1247     } else {
1248     set fNameCaption "[mc {File &name:}]"
1249     }
1250     set iconListCommand [list ::tk::dialog::file::OkCmd $w]
1251     ::tk::SetAmpText $w.f2.lab $fNameCaption
1252     ::tk::IconList_Config $data(icons) \
1253     [list -multiple $multi -command $iconListCommand]
1254     return
1255     }
1256    
1257     # ::tk::dialog::file::UpdateWhenIdle --
1258     #
1259     # Creates an idle event handler which updates the dialog in idle
1260     # time. This is important because loading the directory may take a long
1261     # time and we don't want to load the same directory for multiple times
1262     # due to multiple concurrent events.
1263     #
1264     proc ::tk::dialog::file::UpdateWhenIdle {w} {
1265     upvar ::tk::dialog::file::[winfo name $w] data
1266    
1267     if {[info exists data(updateId)]} {
1268     return
1269     } else {
1270     set data(updateId) [after idle [list ::tk::dialog::file::Update $w]]
1271     }
1272     }
1273    
1274     # ::tk::dialog::file::Update --
1275     #
1276     # Loads the files and directories into the IconList widget. Also
1277     # sets up the directory option menu for quick access to parent
1278     # directories.
1279     #
1280     proc ::tk::dialog::file::Update {w} {
1281    
1282     # This proc may be called within an idle handler. Make sure that the
1283     # window has not been destroyed before this proc is called
1284     if {![winfo exists $w]} {
1285     return
1286     }
1287     set class [winfo class $w]
1288     if {($class ne "TkFDialog") && ($class ne "TkChooseDir")} {
1289     return
1290     }
1291    
1292     set dataName [winfo name $w]
1293     upvar ::tk::dialog::file::$dataName data
1294     variable ::tk::Priv
1295     global tk_library
1296     global asc_tkfbox; #baa
1297     catch {unset data(updateId)}
1298    
1299     if {![info exists Priv(folderImage)]} {
1300     set Priv(folderImage) [image create photo -data {
1301     R0lGODlhEAAMAKEAAAD//wAAAPD/gAAAACH5BAEAAAAALAAAAAAQAAwAAAIghINhyycvVFsB
1302     QtmS3rjaH1Hg141WaT5ouprt2HHcUgAAOw==}]
1303     set Priv(fileImage) [image create photo -data {
1304     R0lGODlhDAAMAKEAALLA3AAAAP//8wAAACH5BAEAAAAALAAAAAAMAAwAAAIgRI4Ha+IfWHsO
1305     rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}]
1306     # baa: adding bitmaps for ascend known file types
1307     set Priv(a4cImage) [image create bitmap -data {
1308     #define a4c_width 12
1309     #define a4c_height 12
1310     static unsigned char a4c_bits[] = {
1311     0x70, 0x00, 0x70, 0x00, 0xac, 0x01, 0x22, 0x06, 0x77, 0x0e, 0x77, 0x0e,
1312     0x77, 0x0e, 0x22, 0x04, 0x54, 0x02, 0x8e, 0x03, 0x8e, 0x03, 0x8e, 0x03};
1313     }]
1314     set Priv(a4lImage) [image create bitmap -data {
1315     #define a4l_width 12
1316     #define a4l_height 12
1317     static unsigned char a4l_bits[] = {
1318     0xff, 0x0f, 0x21, 0x08, 0xad, 0x0b, 0x21, 0x08, 0xa1, 0x0b, 0x21, 0x08,
1319     0xa1, 0x0b, 0x21, 0x08, 0xa1, 0x0b, 0x21, 0x08, 0x21, 0x08, 0xff, 0x0f};
1320     }]
1321     set Priv(a4sImage) [image create bitmap -data {
1322     #define a4s_width 12
1323     #define a4s_height 12
1324     static unsigned char a4s_bits[] = {
1325     0xff, 0x07, 0x01, 0x00, 0xdd, 0x01, 0x01, 0x00, 0xdd, 0x02, 0x01, 0x00,
1326     0xb5, 0x0d, 0x01, 0x00, 0xdd, 0x03, 0x01, 0x00, 0xed, 0x0d, 0x01, 0x00};
1327     }]
1328     set Priv(dotcImage) [image create bitmap -data {
1329     #define c_width 12
1330     #define c_height 12
1331     static unsigned char c_bits[] = {
1332     0xff, 0x0f, 0x01, 0x08, 0xf9, 0x09, 0x0d, 0x0b, 0x05, 0x08, 0x05, 0x08,
1333     0x05, 0x08, 0x05, 0x08, 0x0d, 0x0b, 0xf9, 0x09, 0x01, 0x08, 0xff, 0x0f};
1334     }]
1335     set Priv(dotccImage) [image create bitmap -data {
1336     #define cpp_width 12
1337     #define cpp_height 12
1338     static unsigned char cpp_bits[] = {
1339     0xff, 0x0f, 0x01, 0x00, 0xf9, 0x01, 0x0d, 0x03, 0x05, 0x00, 0xe5, 0x0e,
1340     0xe5, 0x0e, 0x05, 0x00, 0x0d, 0x03, 0xf9, 0x01, 0x01, 0x00, 0xff, 0x0f};
1341     }]
1342     set Priv(dothImage) [image create bitmap -data {
1343     #define h_width 12
1344     #define h_height 12
1345     static unsigned char h_bits[] = {
1346     0xff, 0x0f, 0x01, 0x08, 0x9d, 0x0b, 0x09, 0x09, 0x09, 0x09, 0x09, 0x09,
1347     0xf9, 0x09, 0x99, 0x09, 0x09, 0x09, 0x9d, 0x0b, 0x01, 0x08, 0xff, 0x0f};
1348     }]
1349     set Priv(a4oImage) [image create bitmap -data {
1350     #define opt_width 12
1351     #define opt_height 12
1352     static unsigned char opt_bits[] = {
1353     0x00, 0x00, 0x00, 0x06, 0x00, 0x03, 0x00, 0x01, 0xfe, 0x01, 0x82, 0x01,
1354     0xca, 0x01, 0x5a, 0x01, 0x72, 0x01, 0x22, 0x01, 0xfe, 0x01, 0x00, 0x00};
1355     }]
1356    
1357     }
1358     set folder $Priv(folderImage)
1359     set file $Priv(fileImage)
1360    
1361     set appPWD [pwd]
1362     if {[catch {
1363     cd $data(selectPath)
1364     }]} {
1365     # We cannot change directory to $data(selectPath). $data(selectPath)
1366     # should have been checked before ::tk::dialog::file::Update is called, so
1367     # we normally won't come to here. Anyways, give an error and abort
1368     # action.
1369     tk_messageBox -type ok -parent $w -icon warning -message \
1370     [mc "Cannot change to the directory \"%1\$s\".\nPermission denied." $data(selectPath)]
1371     cd $appPWD
1372     return
1373     }
1374    
1375     # Turn on the busy cursor. BUG?? We haven't disabled X events, though,
1376     # so the user may still click and cause havoc ...
1377     #
1378     set entCursor [$data(ent) cget -cursor]
1379     set dlgCursor [$w cget -cursor]
1380     $data(ent) config -cursor watch
1381     $w config -cursor watch
1382     update idletasks
1383    
1384     ::tk::IconList_DeleteAll $data(icons)
1385    
1386     set showHidden $::tk::dialog::file::showHiddenVar
1387    
1388     # Make the dir list
1389     # Using -directory [pwd] is better in some VFS cases.
1390     set cmd [list glob -tails -directory [pwd] -type d -nocomplain *]
1391     if {$showHidden} { lappend cmd .* }
1392     set dirs [lsort -dictionary -unique [eval $cmd]]
1393     set dirList {}
1394     foreach d $dirs {
1395     if {$d eq "." || $d eq ".."} {
1396     continue
1397     }
1398     lappend dirList $d
1399     }
1400     ::tk::IconList_Add $data(icons) $folder $dirList
1401    
1402     if {$class eq "TkFDialog"} {
1403     # Make the file list if this is a File Dialog, selecting all
1404     # but 'd'irectory type files.
1405     #
1406     set cmd [list glob -tails -directory [pwd] \
1407     -type {f b c l p s} -nocomplain]
1408     if {[string equal $data(filter) *]} {
1409     lappend cmd *
1410     if {$showHidden} { lappend cmd .* }
1411     } else {
1412     eval [list lappend cmd] $data(filter)
1413     }
1414     set fileList [lsort -dictionary -unique [eval $cmd]]
1415     ::tk::IconList_Add $data(icons) $file $fileList
1416     }
1417    
1418     ::tk::IconList_Arrange $data(icons)
1419    
1420     # Update the Directory: option menu
1421     #
1422     set list ""
1423     set dir ""
1424     foreach subdir [file split $data(selectPath)] {
1425     set dir [file join $dir $subdir]
1426     lappend list $dir
1427     }
1428    
1429     $data(dirMenu) delete 0 end
1430     set var [format %s(selectPath) ::tk::dialog::file::$dataName]
1431     foreach path $list {
1432     $data(dirMenu) add command -label $path -command [list set $var $path]
1433     }
1434    
1435     # Restore the PWD to the application's PWD
1436     #
1437     cd $appPWD
1438    
1439     if { [string equal $class TkFDialog] } {
1440     # Restore the Open/Save Button if this is a File Dialog
1441     #
1442     if {[string equal $data(type) open]} {
1443     ::tk::SetAmpText $data(okBtn) [mc "&Open"]
1444     } else {
1445     ::tk::SetAmpText $data(okBtn) [mc "&Save"]
1446     }
1447     }
1448    
1449     # turn off the busy cursor.
1450     #
1451     $data(ent) config -cursor $entCursor
1452     $w config -cursor $dlgCursor
1453     }
1454    
1455     # ::tk::dialog::file::SetPathSilently --
1456     #
1457     # Sets data(selectPath) without invoking the trace procedure
1458     #
1459     proc ::tk::dialog::file::SetPathSilently {w path} {
1460     upvar ::tk::dialog::file::[winfo name $w] data
1461    
1462     trace vdelete data(selectPath) w [list ::tk::dialog::file::SetPath $w]
1463     set data(selectPath) $path
1464     trace variable data(selectPath) w [list ::tk::dialog::file::SetPath $w]
1465     }
1466    
1467    
1468     # This proc gets called whenever data(selectPath) is set
1469     #
1470     proc ::tk::dialog::file::SetPath {w name1 name2 op} {
1471     if {[winfo exists $w]} {
1472     upvar ::tk::dialog::file::[winfo name $w] data
1473     ::tk::dialog::file::UpdateWhenIdle $w
1474     # On directory dialogs, we keep the entry in sync with the currentdir.
1475     if { [string equal [winfo class $w] TkChooseDir] } {
1476     $data(ent) delete 0 end
1477     $data(ent) insert end $data(selectPath)
1478     }
1479     }
1480     }
1481    
1482     # This proc gets called whenever data(filter) is set
1483     #
1484     proc ::tk::dialog::file::SetFilter {w type} {
1485     upvar ::tk::dialog::file::[winfo name $w] data
1486     upvar ::tk::$data(icons) icons
1487    
1488     set data(filter) [lindex $type 1]
1489     $data(typeMenuBtn) config -text [lindex $type 0] -indicatoron 1
1490    
1491     # If we aren't using a default extension, use the one suppled
1492     # by the filter.
1493     if {![info exists data(extUsed)]} {
1494     if {[string length $data(-defaultextension)]} {
1495     set data(extUsed) 1
1496     } else {
1497     set data(extUsed) 0
1498     }
1499     }
1500    
1501     if {!$data(extUsed)} {
1502     # Get the first extension in the list that matches {^\*\.\w+$}
1503     # and remove all * from the filter.
1504     set index [lsearch -regexp $data(filter) {^\*\.\w+$}]
1505     if {$index >= 0} {
1506     set data(-defaultextension) \
1507     [string trimleft [lindex $data(filter) $index] "*"]
1508     } else {
1509     # Couldn't find anything! Reset to a safe default...
1510     set data(-defaultextension) ""
1511     }
1512     }
1513    
1514     $icons(sbar) set 0.0 0.0
1515    
1516     ::tk::dialog::file::UpdateWhenIdle $w
1517     }
1518    
1519     # tk::dialog::file::ResolveFile --
1520     #
1521     # Interpret the user's text input in a file selection dialog.
1522     # Performs:
1523     #
1524     # (1) ~ substitution
1525     # (2) resolve all instances of . and ..
1526     # (3) check for non-existent files/directories
1527     # (4) check for chdir permissions
1528     #
1529     # Arguments:
1530     # context: the current directory you are in
1531     # text: the text entered by the user
1532     # defaultext: the default extension to add to files with no extension
1533     #
1534     # Return vaue:
1535     # [list $flag $directory $file]
1536     #
1537     # flag = OK : valid input
1538     # = PATTERN : valid directory/pattern
1539     # = PATH : the directory does not exist
1540     # = FILE : the directory exists by the file doesn't
1541     # exist
1542     # = CHDIR : Cannot change to the directory
1543     # = ERROR : Invalid entry
1544     #
1545     # directory : valid only if flag = OK or PATTERN or FILE
1546     # file : valid only if flag = OK or PATTERN
1547     #
1548     # directory may not be the same as context, because text may contain
1549     # a subdirectory name
1550     #
1551     proc ::tk::dialog::file::ResolveFile {context text defaultext} {
1552    
1553     set appPWD [pwd]
1554    
1555     set path [::tk::dialog::file::JoinFile $context $text]
1556    
1557     # If the file has no extension, append the default. Be careful not
1558     # to do this for directories, otherwise typing a dirname in the box
1559     # will give back "dirname.extension" instead of trying to change dir.
1560     if {![file isdirectory $path] && [string equal [file ext $path] ""]} {
1561     set path "$path$defaultext"
1562     }
1563    
1564    
1565     if {[catch {file exists $path}]} {
1566     # This "if" block can be safely removed if the following code
1567     # stop generating errors.
1568     #
1569     # file exists ~nonsuchuser
1570     #
1571     return [list ERROR $path ""]
1572     }
1573    
1574     if {[file exists $path]} {
1575     if {[file isdirectory $path]} {
1576     if {[catch {cd $path}]} {
1577     return [list CHDIR $path ""]
1578     }
1579     set directory [pwd]
1580     set file ""
1581     set flag OK
1582     cd $appPWD
1583     } else {
1584     if {[catch {cd [file dirname $path]}]} {
1585     return [list CHDIR [file dirname $path] ""]
1586     }
1587     set directory [pwd]
1588     set file [file tail $path]
1589     set flag OK
1590     cd $appPWD
1591     }
1592     } else {
1593     set dirname [file dirname $path]
1594     if {[file exists $dirname]} {
1595     if {[catch {cd $dirname}]} {
1596     return [list CHDIR $dirname ""]
1597     }
1598     set directory [pwd]
1599     set file [file tail $path]
1600     if {[regexp {[*]|[?]} $file]} {
1601     set flag PATTERN
1602     } else {
1603     set flag FILE
1604     }
1605     cd $appPWD
1606     } else {
1607     set directory $dirname
1608     set file [file tail $path]
1609     set flag PATH
1610     }
1611     }
1612    
1613     return [list $flag $directory $file]
1614     }
1615    
1616    
1617     # Gets called when the entry box gets keyboard focus. We clear the selection
1618     # from the icon list . This way the user can be certain that the input in the
1619     # entry box is the selection.
1620     #
1621     proc ::tk::dialog::file::EntFocusIn {w} {
1622     upvar ::tk::dialog::file::[winfo name $w] data
1623    
1624     if {[string compare [$data(ent) get] ""]} {
1625     $data(ent) selection range 0 end
1626     $data(ent) icursor end
1627     } else {
1628     $data(ent) selection clear
1629     }
1630    
1631     if { [string equal [winfo class $w] TkFDialog] } {
1632     # If this is a File Dialog, make sure the buttons are labeled right.
1633     if {[string equal $data(type) open]} {
1634     ::tk::SetAmpText $data(okBtn) [mc "&Open"]
1635     } else {
1636     ::tk::SetAmpText $data(okBtn) [mc "&Save"]
1637     }
1638     }
1639     }
1640    
1641     proc ::tk::dialog::file::EntFocusOut {w} {
1642     upvar ::tk::dialog::file::[winfo name $w] data
1643    
1644     $data(ent) selection clear
1645     }
1646    
1647    
1648     # Gets called when user presses Return in the "File name" entry.
1649     #
1650     proc ::tk::dialog::file::ActivateEnt {w} {
1651     upvar ::tk::dialog::file::[winfo name $w] data
1652    
1653     set text [$data(ent) get]
1654     if {$data(-multiple)} {
1655     # For the multiple case we have to be careful to get the file
1656     # names as a true list, watching out for a single file with a
1657     # space in the name. Thus we query the IconList directly.
1658    
1659     set selIcos [::tk::IconList_Curselection $data(icons)]
1660     set data(selectFile) ""
1661     if {[llength $selIcos] == 0 && $text ne ""} {
1662     # This assumes the user typed something in without selecting
1663     # files - so assume they only type in a single filename.
1664     ::tk::dialog::file::VerifyFileName $w $text
1665     } else {
1666     foreach item $selIcos {
1667     ::tk::dialog::file::VerifyFileName $w \
1668     [::tk::IconList_Get $data(icons) $item]
1669     }
1670     }
1671     } else {
1672     ::tk::dialog::file::VerifyFileName $w $text
1673     }
1674     }
1675    
1676     # Verification procedure
1677     #
1678     proc ::tk::dialog::file::VerifyFileName {w filename} {
1679     upvar ::tk::dialog::file::[winfo name $w] data
1680    
1681     set list [::tk::dialog::file::ResolveFile $data(selectPath) $filename \
1682     $data(-defaultextension)]
1683     foreach {flag path file} $list {
1684     break
1685     }
1686    
1687     switch -- $flag {
1688     OK {
1689     if {[string equal $file ""]} {
1690     # user has entered an existing (sub)directory
1691     set data(selectPath) $path
1692     $data(ent) delete 0 end
1693     } else {
1694     ::tk::dialog::file::SetPathSilently $w $path
1695     if {$data(-multiple)} {
1696     lappend data(selectFile) $file
1697     } else {
1698     set data(selectFile) $file
1699     }
1700     ::tk::dialog::file::Done $w
1701     }
1702     }
1703     PATTERN {
1704     set data(selectPath) $path
1705     set data(filter) $file
1706     }
1707     FILE {
1708     if {[string equal $data(type) open]} {
1709     tk_messageBox -icon warning -type ok -parent $w \
1710     -message "[mc "File \"%1\$s\" does not exist." [file join $path $file]]"
1711     $data(ent) selection range 0 end
1712     $data(ent) icursor end
1713     } else {
1714     ::tk::dialog::file::SetPathSilently $w $path
1715     if {$data(-multiple)} {
1716     lappend data(selectFile) $file
1717     } else {
1718     set data(selectFile) $file
1719     }
1720     ::tk::dialog::file::Done $w
1721     }
1722     }
1723     PATH {
1724     tk_messageBox -icon warning -type ok -parent $w \
1725     -message "[mc "Directory \"%1\$s\" does not exist." $path]"
1726     $data(ent) selection range 0 end
1727     $data(ent) icursor end
1728     }
1729     CHDIR {
1730     tk_messageBox -type ok -parent $w -message \
1731     "[mc "Cannot change to the directory \"%1\$s\".\nPermission denied." $path]"\
1732     -icon warning
1733     $data(ent) selection range 0 end
1734     $data(ent) icursor end
1735     }
1736     ERROR {
1737     tk_messageBox -type ok -parent $w -message \
1738     "[mc "Invalid file name \"%1\$s\"." $path]"\
1739     -icon warning
1740     $data(ent) selection range 0 end
1741     $data(ent) icursor end
1742     }
1743     }
1744     }
1745    
1746     # Gets called when user presses the Alt-s or Alt-o keys.
1747     #
1748     proc ::tk::dialog::file::InvokeBtn {w key} {
1749     upvar ::tk::dialog::file::[winfo name $w] data
1750    
1751     if {[string equal [$data(okBtn) cget -text] $key]} {
1752     ::tk::ButtonInvoke $data(okBtn)
1753     }
1754     }
1755    
1756     # Gets called when user presses the "parent directory" button
1757     #
1758     proc ::tk::dialog::file::UpDirCmd {w} {
1759     upvar ::tk::dialog::file::[winfo name $w] data
1760    
1761     if {[string compare $data(selectPath) "/"]} {
1762     set data(selectPath) [file dirname $data(selectPath)]
1763     }
1764     }
1765    
1766     # Join a file name to a path name. The "file join" command will break
1767     # if the filename begins with ~
1768     #
1769     proc ::tk::dialog::file::JoinFile {path file} {
1770     if {[string match {~*} $file] && [file exists $path/$file]} {
1771     return [file join $path ./$file]
1772     } else {
1773     return [file join $path $file]
1774     }
1775     }
1776    
1777     # Gets called when user presses the "OK" button
1778     #
1779     proc ::tk::dialog::file::OkCmd {w} {
1780     upvar ::tk::dialog::file::[winfo name $w] data
1781    
1782     set filenames {}
1783     foreach item [::tk::IconList_Curselection $data(icons)] {
1784     lappend filenames [::tk::IconList_Get $data(icons) $item]
1785     }
1786    
1787     if {([llength $filenames] && !$data(-multiple)) || \
1788     ($data(-multiple) && ([llength $filenames] == 1))} {
1789     set filename [lindex $filenames 0]
1790     set file [::tk::dialog::file::JoinFile $data(selectPath) $filename]
1791     if {[file isdirectory $file]} {
1792     ::tk::dialog::file::ListInvoke $w [list $filename]
1793     return
1794     }
1795     }
1796    
1797     ::tk::dialog::file::ActivateEnt $w
1798     }
1799    
1800     # Gets called when user presses the "Cancel" button
1801     #
1802     proc ::tk::dialog::file::CancelCmd {w} {
1803     global asc_tkfbox; # baa
1804     set asc_tkfbox(cancelled) 1; # baa
1805     upvar ::tk::dialog::file::[winfo name $w] data
1806     variable ::tk::Priv
1807    
1808     bind $data(okBtn) <Destroy> {}
1809     set Priv(selectFilePath) ""
1810     }
1811    
1812     # Gets called when user destroys the dialog directly [Bug 987169]
1813     #
1814     proc ::tk::dialog::file::Destroyed {w} {
1815     upvar ::tk::dialog::file::[winfo name $w] data
1816     variable ::tk::Priv
1817    
1818     set Priv(selectFilePath) ""
1819     }
1820    
1821     # Gets called when user browses the IconList widget (dragging mouse, arrow
1822     # keys, etc)
1823     #
1824     proc ::tk::dialog::file::ListBrowse {w} {
1825     upvar ::tk::dialog::file::[winfo name $w] data
1826    
1827     set text {}
1828     foreach item [::tk::IconList_Curselection $data(icons)] {
1829     lappend text [::tk::IconList_Get $data(icons) $item]
1830     }
1831     if {[llength $text] == 0} {
1832     return
1833     }
1834     if { [llength $text] > 1 } {
1835     set newtext {}
1836     foreach file $text {
1837     set fullfile [::tk::dialog::file::JoinFile $data(selectPath) $file]
1838     if { ![file isdirectory $fullfile] } {
1839     lappend newtext $file
1840     }
1841     }
1842     set text $newtext
1843     set isDir 0
1844     } else {
1845     set text [lindex $text 0]
1846     set file [::tk::dialog::file::JoinFile $data(selectPath) $text]
1847     set isDir [file isdirectory $file]
1848     }
1849     if {!$isDir} {
1850     $data(ent) delete 0 end
1851     $data(ent) insert 0 $text
1852    
1853     if { [string equal [winfo class $w] TkFDialog] } {
1854     if {[string equal $data(type) open]} {
1855     ::tk::SetAmpText $data(okBtn) [mc "&Open"]
1856     } else {
1857     ::tk::SetAmpText $data(okBtn) [mc "&Save"]
1858     }
1859     }
1860     } else {
1861     if { [string equal [winfo class $w] TkFDialog] } {
1862     ::tk::SetAmpText $data(okBtn) [mc "&Open"]
1863     }
1864     }
1865     }
1866    
1867     # Gets called when user invokes the IconList widget (double-click,
1868     # Return key, etc)
1869     #
1870     proc ::tk::dialog::file::ListInvoke {w filenames} {
1871     upvar ::tk::dialog::file::[winfo name $w] data
1872    
1873     if {[llength $filenames] == 0} {
1874     return
1875     }
1876    
1877     set file [::tk::dialog::file::JoinFile $data(selectPath) \
1878     [lindex $filenames 0]]
1879    
1880     set class [winfo class $w]
1881     if {[string equal $class TkChooseDir] || [file isdirectory $file]} {
1882     set appPWD [pwd]
1883     if {[catch {cd $file}]} {
1884     tk_messageBox -type ok -parent $w -message \
1885     "[mc "Cannot change to the directory \"%1\$s\".\nPermission denied." $file]"\
1886     -icon warning
1887     } else {
1888     cd $appPWD
1889     set data(selectPath) $file
1890     }
1891     } else {
1892     if {$data(-multiple)} {
1893     set data(selectFile) $filenames
1894     } else {
1895     set data(selectFile) $file
1896     }
1897     ::tk::dialog::file::Done $w
1898     }
1899     }
1900    
1901     # ::tk::dialog::file::Done --
1902     #
1903     # Gets called when user has input a valid filename. Pops up a
1904     # dialog box to confirm selection when necessary. Sets the
1905     # tk::Priv(selectFilePath) variable, which will break the "vwait"
1906     # loop in ::tk::dialog::file:: and return the selected filename to the
1907     # script that calls tk_getOpenFile or tk_getSaveFile
1908     #
1909     proc ::tk::dialog::file::Done {w {selectFilePath ""}} {
1910     upvar ::tk::dialog::file::[winfo name $w] data
1911     variable ::tk::Priv
1912    
1913     if {[string equal $selectFilePath ""]} {
1914     if {$data(-multiple)} {
1915     set selectFilePath {}
1916     foreach f $data(selectFile) {
1917     lappend selectFilePath [::tk::dialog::file::JoinFile \
1918     $data(selectPath) $f]
1919     }
1920     } else {
1921     set selectFilePath [::tk::dialog::file::JoinFile \
1922     $data(selectPath) $data(selectFile)]
1923     }
1924    
1925     set Priv(selectFile) $data(selectFile)
1926     set Priv(selectPath) $data(selectPath)
1927    
1928     if {[string equal $data(type) save]} {
1929     if {[file exists $selectFilePath]} {
1930     set reply [tk_messageBox -icon warning -type yesno\
1931     -parent $w -message \
1932     "[mc "File \"%1\$s\" already exists.\nDo you want to overwrite it?" $selectFilePath]"]
1933     if {[string equal $reply "no"]} {
1934     return
1935     }
1936     }
1937     }
1938     }
1939     bind $data(okBtn) <Destroy> {}
1940     set Priv(selectFilePath) $selectFilePath
1941     }

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22