root/tk-8.0/tags/rat_4_2_6/library/tkfbox.tcl @ 1291

Revision 1291, 36.7 KB (checked in by anonymous, 14 years ago)

This commit was manufactured by cvs2svn to create tag 'rat_4_2_6'.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
Line 
1# 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#       selectinf 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# SCCS: @(#) tkfbox.tcl 1.13 97/10/01 14:51:01
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
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# tkFDialog dialog box.
28#
29#----------------------------------------------------------------------
30
31# tkIconList --
32#
33#       Creates an IconList widget.
34#
35proc tkIconList {w args} {
36    upvar #0 $w data
37
38    tkIconList_Config $w $args
39    tkIconList_Create $w
40}
41
42# tkIconList_Config --
43#
44#       Configure the widget variables of IconList, according to the command
45#       line arguments.
46#
47proc tkIconList_Config {w argList} {
48    upvar #0 $w data
49
50    # 1: the configuration specs
51    #
52    set specs {
53        {-browsecmd "" "" ""}
54        {-command "" "" ""}
55    }
56
57    # 2: parse the arguments
58    #
59    tclParseConfigSpec $w $specs "" $argList
60}
61
62# tkIconList_Create --
63#
64#       Creates an IconList widget by assembling a canvas widget and a
65#       scrollbar widget. Sets all the bindings necessary for the IconList's
66#       operations.
67#
68proc tkIconList_Create {w} {
69    upvar #0 $w data
70
71    frame $w
72    set data(sbar)   [scrollbar $w.sbar -orient horizontal \
73        -highlightthickness 0 -takefocus 0]
74    set data(canvas) [canvas $w.canvas -bd 2 -relief sunken \
75        -width 400 -height 120 -takefocus 1]
76    pack $data(sbar) -side bottom -fill x -padx 2
77    pack $data(canvas) -expand yes -fill both
78
79    $data(sbar) config -command "$data(canvas) xview"
80    $data(canvas) config -xscrollcommand "$data(sbar) set"
81
82    # Initializes the max icon/text width and height and other variables
83    #
84    set data(maxIW) 1
85    set data(maxIH) 1
86    set data(maxTW) 1
87    set data(maxTH) 1
88    set data(numItems) 0
89    set data(curItem)  {}
90    set data(noScroll) 1
91
92    # Creates the event bindings.
93    #
94    bind $data(canvas) <Configure> "tkIconList_Arrange $w"
95
96    bind $data(canvas) <1>         "tkIconList_Btn1 $w %x %y"
97    bind $data(canvas) <B1-Motion> "tkIconList_Motion1 $w %x %y"
98    bind $data(canvas) <Double-1>  "tkIconList_Double1 $w %x %y"
99    bind $data(canvas) <ButtonRelease-1> "tkCancelRepeat"
100    bind $data(canvas) <B1-Leave>  "tkIconList_Leave1 $w %x %y"
101    bind $data(canvas) <B1-Enter>  "tkCancelRepeat"
102
103    bind $data(canvas) <Up>        "tkIconList_UpDown $w -1"
104    bind $data(canvas) <Down>      "tkIconList_UpDown $w  1"
105    bind $data(canvas) <Left>      "tkIconList_LeftRight $w -1"
106    bind $data(canvas) <Right>     "tkIconList_LeftRight $w  1"
107    bind $data(canvas) <Return>    "tkIconList_ReturnKey $w"
108    bind $data(canvas) <KeyPress>  "tkIconList_KeyPress $w %A"
109    bind $data(canvas) <Control-KeyPress> ";"
110    bind $data(canvas) <Alt-KeyPress>  ";"
111
112    bind $data(canvas) <FocusIn>   "tkIconList_FocusIn $w"
113
114    return $w
115}
116
117# tkIconList_AutoScan --
118#
119# This procedure is invoked when the mouse leaves an entry window
120# with button 1 down.  It scrolls the window up, down, left, or
121# right, depending on where the mouse left the window, and reschedules
122# itself as an "after" command so that the window continues to scroll until
123# the mouse moves back into the window or the mouse button is released.
124#
125# Arguments:
126# w -           The IconList window.
127#
128proc tkIconList_AutoScan {w} {
129    upvar #0 $w data
130    global tkPriv
131
132    if {![winfo exists $w]} return
133    set x $tkPriv(x)
134    set y $tkPriv(y)
135
136    if {$data(noScroll)} {
137        return
138    }
139    if {$x >= [winfo width $data(canvas)]} {
140        $data(canvas) xview scroll 1 units
141    } elseif {$x < 0} {
142        $data(canvas) xview scroll -1 units
143    } elseif {$y >= [winfo height $data(canvas)]} {
144        # do nothing
145    } elseif {$y < 0} {
146        # do nothing
147    } else {
148        return
149    }
150
151    tkIconList_Motion1 $w $x $y
152    set tkPriv(afterId) [after 50 tkIconList_AutoScan $w]
153}
154
155# Deletes all the items inside the canvas subwidget and reset the IconList's
156# state.
157#
158proc tkIconList_DeleteAll {w} {
159    upvar #0 $w data
160    upvar #0 $w:itemList itemList
161
162    $data(canvas) delete all
163    catch {unset data(selected)}
164    catch {unset data(rect)}
165    catch {unset data(list)}
166    catch {unset itemList}
167    set data(maxIW) 1
168    set data(maxIH) 1
169    set data(maxTW) 1
170    set data(maxTH) 1
171    set data(numItems) 0
172    set data(curItem)  {}
173    set data(noScroll) 1
174    $data(sbar) set 0.0 1.0
175    $data(canvas) xview moveto 0
176}
177
178# Adds an icon into the IconList with the designated image and text
179#
180proc tkIconList_Add {w image text} {
181    upvar #0 $w data
182    upvar #0 $w:itemList itemList
183    upvar #0 $w:textList textList
184
185    set iTag [$data(canvas) create image 0 0 -image $image -anchor nw]
186    set tTag [$data(canvas) create text  0 0 -text  $text  -anchor nw \
187        -font $data(font)]
188    set rTag [$data(canvas) create rect  0 0 0 0 -fill "" -outline ""]
189   
190    set b [$data(canvas) bbox $iTag]
191    set iW [expr {[lindex $b 2]-[lindex $b 0]}]
192    set iH [expr {[lindex $b 3]-[lindex $b 1]}]
193    if {$data(maxIW) < $iW} {
194        set data(maxIW) $iW
195    }
196    if {$data(maxIH) < $iH} {
197        set data(maxIH) $iH
198    }
199   
200    set b [$data(canvas) bbox $tTag]
201    set tW [expr {[lindex $b 2]-[lindex $b 0]}]
202    set tH [expr {[lindex $b 3]-[lindex $b 1]}]
203    if {$data(maxTW) < $tW} {
204        set data(maxTW) $tW
205    }
206    if {$data(maxTH) < $tH} {
207        set data(maxTH) $tH
208    }
209   
210    lappend data(list) [list $iTag $tTag $rTag $iW $iH $tW $tH $data(numItems)]
211    set itemList($rTag) [list $iTag $tTag $text $data(numItems)]
212    set textList($data(numItems)) [string tolower $text]
213    incr data(numItems)
214}
215
216# Places the icons in a column-major arrangement.
217#
218proc tkIconList_Arrange {w} {
219    upvar #0 $w data
220
221    if {![info exists data(list)]} {
222        if {[info exists data(canvas)] && [winfo exists $data(canvas)]} {
223            set data(noScroll) 1
224            $data(sbar) config -command ""
225        }
226        return
227    }
228
229    set W [winfo width  $data(canvas)]
230    set H [winfo height $data(canvas)]
231    set pad [expr {[$data(canvas) cget -highlightthickness] + \
232            [$data(canvas) cget -bd]}]
233    if {$pad < 2} {
234        set pad 2
235    }
236
237    incr W -[expr {$pad*2}]
238    incr H -[expr {$pad*2}]
239
240    set dx [expr {$data(maxIW) + $data(maxTW) + 8}]
241    if {$data(maxTH) > $data(maxIH)} {
242        set dy $data(maxTH)
243    } else {
244        set dy $data(maxIH)
245    }
246    incr dy 2
247    set shift [expr {$data(maxIW) + 4}]
248
249    set x [expr {$pad * 2}]
250    set y [expr {$pad * 1}] ; # Why * 1 ?
251    set usedColumn 0
252    foreach sublist $data(list) {
253        set usedColumn 1
254        set iTag [lindex $sublist 0]
255        set tTag [lindex $sublist 1]
256        set rTag [lindex $sublist 2]
257        set iW   [lindex $sublist 3]
258        set iH   [lindex $sublist 4]
259        set tW   [lindex $sublist 5]
260        set tH   [lindex $sublist 6]
261
262        set i_dy [expr {($dy - $iH)/2}]
263        set t_dy [expr {($dy - $tH)/2}]
264
265        $data(canvas) coords $iTag $x                    [expr {$y + $i_dy}]
266        $data(canvas) coords $tTag [expr {$x + $shift}]  [expr {$y + $t_dy}]
267        $data(canvas) coords $tTag [expr {$x + $shift}]  [expr {$y + $t_dy}]
268        $data(canvas) coords $rTag $x $y [expr {$x+$dx}] [expr {$y+$dy}]
269
270        incr y $dy
271        if {($y + $dy) > $H} {
272            set y [expr {$pad * 1}] ; # *1 ?
273            incr x $dx
274            set usedColumn 0
275        }
276    }
277
278    if {$usedColumn} {
279        set sW [expr {$x + $dx}]
280    } else {
281        set sW $x
282    }
283
284    if {$sW < $W} {
285        $data(canvas) config -scrollregion "$pad $pad $sW $H"
286        $data(sbar) config -command ""
287        $data(canvas) xview moveto 0
288        set data(noScroll) 1
289    } else {
290        $data(canvas) config -scrollregion "$pad $pad $sW $H"
291        $data(sbar) config -command "$data(canvas) xview"
292        set data(noScroll) 0
293    }
294
295    set data(itemsPerColumn) [expr {($H-$pad)/$dy}]
296    if {$data(itemsPerColumn) < 1} {
297        set data(itemsPerColumn) 1
298    }
299
300    if {$data(curItem) != {}} {
301        tkIconList_Select $w [lindex [lindex $data(list) $data(curItem)] 2] 0
302    }
303}
304
305# Gets called when the user invokes the IconList (usually by double-clicking
306# or pressing the Return key).
307#
308proc tkIconList_Invoke {w} {
309    upvar #0 $w data
310
311    if {[string compare $data(-command) ""] && [info exists data(selected)]} {
312        eval $data(-command)
313    }
314}
315
316# tkIconList_See --
317#
318#       If the item is not (completely) visible, scroll the canvas so that
319#       it becomes visible.
320proc tkIconList_See {w rTag} {
321    upvar #0 $w data
322    upvar #0 $w:itemList itemList
323
324    if {$data(noScroll)} {
325        return
326    }
327    set sRegion [$data(canvas) cget -scrollregion]
328    if {![string compare $sRegion {}]} {
329        return
330    }
331
332    if {![info exists itemList($rTag)]} {
333        return
334    }
335
336
337    set bbox [$data(canvas) bbox $rTag]
338    set pad [expr {[$data(canvas) cget -highlightthickness] + \
339            [$data(canvas) cget -bd]}]
340
341    set x1 [lindex $bbox 0]
342    set x2 [lindex $bbox 2]
343    incr x1 -[expr {$pad * 2}]
344    incr x2 -[expr {$pad * 1}] ; # *1 ?
345
346    set cW [expr {[winfo width $data(canvas)] - $pad*2}]
347
348    set scrollW [expr {[lindex $sRegion 2]-[lindex $sRegion 0]+1}]
349    set dispX [expr {int([lindex [$data(canvas) xview] 0]*$scrollW)}]
350    set oldDispX $dispX
351
352    # check if out of the right edge
353    #
354    if {($x2 - $dispX) >= $cW} {
355        set dispX [expr {$x2 - $cW}]
356    }
357    # check if out of the left edge
358    #
359    if {($x1 - $dispX) < 0} {
360        set dispX $x1
361    }
362
363    if {$oldDispX != $dispX} {
364        set fraction [expr {double($dispX)/double($scrollW)}]
365        $data(canvas) xview moveto $fraction
366    }
367}
368
369proc tkIconList_SelectAtXY {w x y} {
370    upvar #0 $w data
371
372    tkIconList_Select $w [$data(canvas) find closest \
373        [$data(canvas) canvasx $x] [$data(canvas) canvasy $y]]
374}
375
376proc tkIconList_Select {w rTag {callBrowse 1}} {
377    upvar #0 $w data
378    upvar #0 $w:itemList itemList
379
380    if {![info exists itemList($rTag)]} {
381        return
382    }
383    set iTag   [lindex $itemList($rTag) 0]
384    set tTag   [lindex $itemList($rTag) 1]
385    set text   [lindex $itemList($rTag) 2]
386    set serial [lindex $itemList($rTag) 3]
387
388    if {![info exists data(rect)]} {
389        set data(rect) [$data(canvas) create rect 0 0 0 0 \
390            -fill #a0a0ff -outline #a0a0ff]
391    }
392    $data(canvas) lower $data(rect)
393    set bbox [$data(canvas) bbox $tTag]
394    eval $data(canvas) coords $data(rect) $bbox
395
396    set data(curItem) $serial
397    set data(selected) $text
398   
399    if {$callBrowse} {
400        if {[string compare $data(-browsecmd) ""]} {
401            eval $data(-browsecmd) [list $text]
402        }
403    }
404}
405
406proc tkIconList_Unselect {w} {
407    upvar #0 $w data
408
409    if {[info exists data(rect)]} {
410        $data(canvas) delete $data(rect)
411        unset data(rect)
412    }
413    if {[info exists data(selected)]} {
414        unset data(selected)
415    }
416    set data(curItem)  {}
417}
418
419# Returns the selected item
420#
421proc tkIconList_Get {w} {
422    upvar #0 $w data
423
424    if {[info exists data(selected)]} {
425        return $data(selected)
426    } else {
427        return ""
428    }
429}
430
431
432proc tkIconList_Btn1 {w x y} {
433    upvar #0 $w data
434
435    focus $data(canvas)
436    tkIconList_SelectAtXY $w $x $y
437}
438
439# Gets called on button-1 motions
440#
441proc tkIconList_Motion1 {w x y} {
442    global tkPriv
443    set tkPriv(x) $x
444    set tkPriv(y) $y
445
446    tkIconList_SelectAtXY $w $x $y
447}
448
449proc tkIconList_Double1 {w x y} {
450    upvar #0 $w data
451
452    if {$data(curItem) != {}} {
453        tkIconList_Invoke $w
454    }
455}
456
457proc tkIconList_ReturnKey {w} {
458    tkIconList_Invoke $w
459}
460
461proc tkIconList_Leave1 {w x y} {
462    global tkPriv
463
464    set tkPriv(x) $x
465    set tkPriv(y) $y
466    tkIconList_AutoScan $w
467}
468
469proc tkIconList_FocusIn {w} {
470    upvar #0 $w data
471
472    if {![info exists data(list)]} {
473        return
474    }
475
476    if {$data(curItem) == {}} {
477        set rTag [lindex [lindex $data(list) 0] 2]
478        tkIconList_Select $w $rTag
479    }
480}
481
482# tkIconList_UpDown --
483#
484# Moves the active element up or down by one element
485#
486# Arguments:
487# w -           The IconList widget.
488# amount -      +1 to move down one item, -1 to move back one item.
489#
490proc tkIconList_UpDown {w amount} {
491    upvar #0 $w data
492
493    if {![info exists data(list)]} {
494        return
495    }
496
497    if {$data(curItem) == {}} {
498        set rTag [lindex [lindex $data(list) 0] 2]
499    } else {
500        set oldRTag [lindex [lindex $data(list) $data(curItem)] 2]
501        set rTag [lindex [lindex $data(list) [expr {$data(curItem)+$amount}]] 2]
502        if {![string compare $rTag ""]} {
503            set rTag $oldRTag
504        }
505    }
506
507    if {[string compare $rTag ""]} {
508        tkIconList_Select $w $rTag
509        tkIconList_See $w $rTag
510    }
511}
512
513# tkIconList_LeftRight --
514#
515# Moves the active element left or right by one column
516#
517# Arguments:
518# w -           The IconList widget.
519# amount -      +1 to move right one column, -1 to move left one column.
520#
521proc tkIconList_LeftRight {w amount} {
522    upvar #0 $w data
523
524    if {![info exists data(list)]} {
525        return
526    }
527    if {$data(curItem) == {}} {
528        set rTag [lindex [lindex $data(list) 0] 2]
529    } else {
530        set oldRTag [lindex [lindex $data(list) $data(curItem)] 2]
531        set newItem [expr {$data(curItem)+($amount*$data(itemsPerColumn))}]
532        set rTag [lindex [lindex $data(list) $newItem] 2]
533        if {![string compare $rTag ""]} {
534            set rTag $oldRTag
535        }
536    }
537
538    if {[string compare $rTag ""]} {
539        tkIconList_Select $w $rTag
540        tkIconList_See $w $rTag
541    }
542}
543
544#----------------------------------------------------------------------
545#               Accelerator key bindings
546#----------------------------------------------------------------------
547
548# tkIconList_KeyPress --
549#
550#       Gets called when user enters an arbitrary key in the listbox.
551#
552proc tkIconList_KeyPress {w key} {
553    global tkPriv
554
555    append tkPriv(ILAccel,$w) $key
556    tkIconList_Goto $w $tkPriv(ILAccel,$w)
557    catch {
558        after cancel $tkPriv(ILAccel,$w,afterId)
559    }
560    set tkPriv(ILAccel,$w,afterId) [after 500 tkIconList_Reset $w]
561}
562
563proc tkIconList_Goto {w text} {
564    upvar #0 $w data
565    upvar #0 $w:textList textList
566    global tkPriv
567   
568    if {![info exists data(list)]} {
569        return
570    }
571
572    if {[string length $text] == 0} {
573        return
574    }
575
576    if {$data(curItem) == {} || $data(curItem) == 0} {
577        set start  0
578    } else {
579        set start  $data(curItem)
580    }
581
582    set text [string tolower $text]
583    set theIndex -1
584    set less 0
585    set len [string length $text]
586    set len0 [expr {$len-1}]
587    set i $start
588
589    # Search forward until we find a filename whose prefix is an exact match
590    # with $text
591    while 1 {
592        set sub [string range $textList($i) 0 $len0]
593        if {[string compare $text $sub] == 0} {
594            set theIndex $i
595            break
596        }
597        incr i
598        if {$i == $data(numItems)} {
599            set i 0
600        }
601        if {$i == $start} {
602            break
603        }
604    }
605
606    if {$theIndex > -1} {
607        set rTag [lindex [lindex $data(list) $theIndex] 2]
608        tkIconList_Select $w $rTag 0
609        tkIconList_See $w $rTag
610    }
611}
612
613proc tkIconList_Reset {w} {
614    global tkPriv
615
616    catch {unset tkPriv(ILAccel,$w)}
617}
618
619#----------------------------------------------------------------------
620#
621#                     F I L E   D I A L O G
622#
623#----------------------------------------------------------------------
624
625# tkFDialog --
626#
627#       Implements the TK file selection dialog. This dialog is used when
628#       the tk_strictMotif flag is set to false. This procedure shouldn't
629#       be called directly. Call tk_getOpenFile or tk_getSaveFile instead.
630#
631proc tkFDialog {args} {
632    global tkPriv
633    set w __tk_filedialog
634    upvar #0 $w data
635
636    if {![string compare [lindex [info level 0] 0] tk_getOpenFile]} {
637        set type open
638    } else {
639        set type save
640    }
641
642    tkFDialog_Config $w $type $args
643
644    if {![string compare $data(-parent) .]} {
645        set w .$w
646    } else {
647        set w $data(-parent).$w
648    }
649
650    # (re)create the dialog box if necessary
651    #
652    if {![winfo exists $w]} {
653        tkFDialog_Create $w
654    } elseif {[string compare [winfo class $w] TkFDialog]} {
655        destroy $w
656        tkFDialog_Create $w
657    } else {
658        set data(dirMenuBtn) $w.f1.menu
659        set data(dirMenu) $w.f1.menu.menu
660        set data(upBtn) $w.f1.up
661        set data(icons) $w.icons
662        set data(ent) $w.f2.ent
663        set data(typeMenuLab) $w.f3.lab
664        set data(typeMenuBtn) $w.f3.menu
665        set data(typeMenu) $data(typeMenuBtn).m
666        set data(okBtn) $w.f2.ok
667        set data(cancelBtn) $w.f3.cancel
668    }
669    wm transient $w $data(-parent)
670
671    # 5. Initialize the file types menu
672    #
673    if {$data(-filetypes) != {}} {
674        $data(typeMenu) delete 0 end
675        foreach type $data(-filetypes) {
676            set title  [lindex $type 0]
677            set filter [lindex $type 1]
678            $data(typeMenu) add command -label $title \
679                -command [list tkFDialog_SetFilter $w $type]
680        }
681        tkFDialog_SetFilter $w [lindex $data(-filetypes) 0]
682        $data(typeMenuBtn) config -state normal
683        $data(typeMenuLab) config -state normal
684    } else {
685        set data(filter) "*"
686        $data(typeMenuBtn) config -state disabled -takefocus 0
687        $data(typeMenuLab) config -state disabled
688    }
689
690    tkFDialog_UpdateWhenIdle $w
691
692    # 6. Withdraw the window, then update all the geometry information
693    # so we know how big it wants to be, then center the window in the
694    # display and de-iconify it.
695
696    wm withdraw $w
697    update idletasks
698    set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
699            - [winfo vrootx [winfo parent $w]]}]
700    set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
701            - [winfo vrooty [winfo parent $w]]}]
702    wm geom $w [winfo reqwidth $w]x[winfo reqheight $w]+$x+$y
703    wm deiconify $w
704    wm title $w $data(-title)
705
706    # 7. Set a grab and claim the focus too.
707
708    set oldFocus [focus]
709    set oldGrab [grab current $w]
710    if {$oldGrab != ""} {
711        set grabStatus [grab status $oldGrab]
712    }
713    grab $w
714    focus $data(ent)
715    $data(ent) delete 0 end
716    $data(ent) insert 0 $data(selectFile)
717    $data(ent) select from 0
718    $data(ent) select to   end
719    $data(ent) icursor end
720
721    # 8. Wait for the user to respond, then restore the focus and
722    # return the index of the selected button.  Restore the focus
723    # before deleting the window, since otherwise the window manager
724    # may take the focus away so we can't redirect it.  Finally,
725    # restore any grab that was in effect.
726
727    tkwait variable tkPriv(selectFilePath)
728    catch {focus $oldFocus}
729    grab release $w
730    wm withdraw $w
731    if {$oldGrab != ""} {
732        if {$grabStatus == "global"} {
733            grab -global $oldGrab
734        } else {
735            grab $oldGrab
736        }
737    }
738    return $tkPriv(selectFilePath)
739}
740
741# tkFDialog_Config --
742#
743#       Configures the TK filedialog according to the argument list
744#
745proc tkFDialog_Config {w type argList} {
746    upvar #0 $w data
747
748    set data(type) $type
749
750    # 1: the configuration specs
751    #
752    set specs {
753        {-defaultextension "" "" ""}
754        {-filetypes "" "" ""}
755        {-initialdir "" "" ""}
756        {-initialfile "" "" ""}
757        {-parent "" "" "."}
758        {-title "" "" ""}
759    }
760
761    # 2: default values depending on the type of the dialog
762    #
763    if {![info exists data(selectPath)]} {
764        # first time the dialog has been popped up
765        set data(selectPath) [pwd]
766        set data(selectFile) ""
767    }
768
769    # 3: parse the arguments
770    #
771    tclParseConfigSpec $w $specs "" $argList
772
773    if {![string compare $data(-title) ""]} {
774        if {![string compare $type "open"]} {
775            set data(-title) "Open"
776        } else {
777            set data(-title) "Save As"
778        }
779    }
780
781    # 4: set the default directory and selection according to the -initial
782    #    settings
783    #
784    if {[string compare $data(-initialdir) ""]} {
785       
786        if {[file isdirectory $data(-initialdir)]} {
787            set data(selectPath) [glob $data(-initialdir)]
788        } else {
789            set data(selectPath) [pwd]
790        }
791
792        # Convert the initialdir to an absolute path name.
793
794        set old [pwd]
795        cd $data(selectPath)
796        set data(selectPath) [pwd]
797        cd $old
798    }
799    set data(selectFile) $data(-initialfile)
800
801    # 5. Parse the -filetypes option
802    #
803    set data(-filetypes) [tkFDGetFileTypes $data(-filetypes)]
804
805    if {![winfo exists $data(-parent)]} {
806        error "bad window path name \"$data(-parent)\""
807    }
808}
809
810proc tkFDialog_Create {w} {
811    set dataName [lindex [split $w .] end]
812    upvar #0 $dataName data
813    global tk_library
814
815    toplevel $w -class TkFDialog
816
817    # f1: the frame with the directory option menu
818    #
819    set f1 [frame $w.f1]
820    label $f1.lab -text "Directory:" -under 0
821    set data(dirMenuBtn) $f1.menu
822    set data(dirMenu) [tk_optionMenu $f1.menu [format %s(selectPath) $dataName] ""]
823    set data(upBtn) [button $f1.up]
824    if {![info exists tkPriv(updirImage)]} {
825        set tkPriv(updirImage) [image create bitmap -data {#define updir_width 28 #define updir_height 16
826static char updir_bits[] = {
827   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
828   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
829   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
830   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
831   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
832   0xf0, 0xff, 0xff, 0x01};}]
833    }
834    $data(upBtn) config -image $tkPriv(updirImage)
835
836    $f1.menu config -takefocus 1 -highlightthickness 2
837 
838    pack $data(upBtn) -side right -padx 4 -fill both
839    pack $f1.lab -side left -padx 4 -fill both
840    pack $f1.menu -expand yes -fill both -padx 4
841
842    # data(icons): the IconList that list the files and directories.
843    #
844    set data(icons) [tkIconList $w.icons \
845        -browsecmd "tkFDialog_ListBrowse $w" \
846        -command   "tkFDialog_OkCmd $w"]
847
848    # f2: the frame with the OK button and the "file name" field
849    #
850    set f2 [frame $w.f2 -bd 0]
851    label $f2.lab -text "File name:" -anchor e -width 14 -under 5 -pady 0
852    set data(ent) [entry $f2.ent]
853
854    # The font to use for the icons. The default Canvas font on Unix
855    # is just deviant.
856    global $w.icons
857    set $w.icons(font) [$data(ent) cget -font]
858
859    # f3: the frame with the cancel button and the file types field
860    #
861    set f3 [frame $w.f3 -bd 0]
862
863    # The "File of types:" label needs to be grayed-out when
864    # -filetypes are not specified. The label widget does not support
865    # grayed-out text on monochrome displays. Therefore, we have to
866    # use a button widget to emulate a label widget (by setting its
867    # bindtags)
868
869    set data(typeMenuLab) [button $f3.lab -text "Files of type:" \
870        -anchor e -width 14 -under 9 \
871        -bd [$f2.lab cget -bd] \
872        -highlightthickness [$f2.lab cget -highlightthickness] \
873        -relief [$f2.lab cget -relief] \
874        -padx [$f2.lab cget -padx] \
875        -pady [$f2.lab cget -pady]]
876    bindtags $data(typeMenuLab) [list $data(typeMenuLab) Label \
877            [winfo toplevel $data(typeMenuLab)] all]
878
879    set data(typeMenuBtn) [menubutton $f3.menu -indicatoron 1 -menu $f3.menu.m]
880    set data(typeMenu) [menu $data(typeMenuBtn).m -tearoff 0]
881    $data(typeMenuBtn) config -takefocus 1 -highlightthickness 2 \
882        -relief raised -bd 2 -anchor w
883
884    # the okBtn is created after the typeMenu so that the keyboard traversal
885    # is in the right order
886    set data(okBtn)     [button $f2.ok     -text OK     -under 0 -width 6 \
887        -default active -pady 3]
888    set data(cancelBtn) [button $f3.cancel -text Cancel -under 0 -width 6\
889        -default normal -pady 3]
890
891    # pack the widgets in f2 and f3
892    #
893    pack $data(okBtn) -side right -padx 4 -anchor e
894    pack $f2.lab -side left -padx 4
895    pack $f2.ent -expand yes -fill x -padx 2 -pady 0
896   
897    pack $data(cancelBtn) -side right -padx 4 -anchor w
898    pack $data(typeMenuLab) -side left -padx 4
899    pack $data(typeMenuBtn) -expand yes -fill x -side right
900
901    # Pack all the frames together. We are done with widget construction.
902    #
903    pack $f1 -side top -fill x -pady 4
904    pack $f3 -side bottom -fill x
905    pack $f2 -side bottom -fill x
906    pack $data(icons) -expand yes -fill both -padx 4 -pady 1
907
908    # Set up the event handlers
909    #
910    bind $data(ent) <Return>  "tkFDialog_ActivateEnt $w"
911   
912    $data(upBtn)     config -command "tkFDialog_UpDirCmd $w"
913    $data(okBtn)     config -command "tkFDialog_OkCmd $w"
914    $data(cancelBtn) config -command "tkFDialog_CancelCmd $w"
915
916    trace variable data(selectPath) w "tkFDialog_SetPath $w"
917
918    bind $w <Alt-d> "focus $data(dirMenuBtn)"
919    bind $w <Alt-t> [format {
920        if {"[%s cget -state]" == "normal"} {
921            focus %s
922        }
923    } $data(typeMenuBtn) $data(typeMenuBtn)]
924    bind $w <Alt-n> "focus $data(ent)"
925    bind $w <KeyPress-Escape> "tkButtonInvoke $data(cancelBtn)"
926    bind $w <Alt-c> "tkButtonInvoke $data(cancelBtn)"
927    bind $w <Alt-o> "tkFDialog_InvokeBtn $w Open"
928    bind $w <Alt-s> "tkFDialog_InvokeBtn $w Save"
929
930    wm protocol $w WM_DELETE_WINDOW "tkFDialog_CancelCmd $w"
931
932    # Build the focus group for all the entries
933    #
934    tkFocusGroup_Create $w
935    tkFocusGroup_BindIn $w  $data(ent) "tkFDialog_EntFocusIn $w"
936    tkFocusGroup_BindOut $w $data(ent) "tkFDialog_EntFocusOut $w"
937}
938
939# tkFDialog_UpdateWhenIdle --
940#
941#       Creates an idle event handler which updates the dialog in idle
942#       time. This is important because loading the directory may take a long
943#       time and we don't want to load the same directory for multiple times
944#       due to multiple concurrent events.
945#
946proc tkFDialog_UpdateWhenIdle {w} {
947    upvar #0 [winfo name $w] data
948
949    if {[info exists data(updateId)]} {
950        return
951    } else {
952        set data(updateId) [after idle tkFDialog_Update $w]
953    }
954}
955
956# tkFDialog_Update --
957#
958#       Loads the files and directories into the IconList widget. Also
959#       sets up the directory option menu for quick access to parent
960#       directories.
961#
962proc tkFDialog_Update {w} {
963
964    # This proc may be called within an idle handler. Make sure that the
965    # window has not been destroyed before this proc is called
966    if {![winfo exists $w] || [string compare [winfo class $w] TkFDialog]} {
967        return
968    }
969
970    set dataName [winfo name $w]
971    upvar #0 $dataName data
972    global tk_library tkPriv
973    catch {unset data(updateId)}
974
975    if {![info exists tkPriv(folderImage)]} {
976        set tkPriv(folderImage) [image create photo -data {
977R0lGODlhEAAMAKEAAAD//wAAAPD/gAAAACH5BAEAAAAALAAAAAAQAAwAAAIghINhyycvVFsB
978QtmS3rjaH1Hg141WaT5ouprt2HHcUgAAOw==}]
979        set tkPriv(fileImage)   [image create photo -data {
980R0lGODlhDAAMAKEAALLA3AAAAP//8wAAACH5BAEAAAAALAAAAAAMAAwAAAIgRI4Ha+IfWHsO
981rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}]
982    }
983    set folder $tkPriv(folderImage)
984    set file   $tkPriv(fileImage)
985
986    set appPWD [pwd]
987    if {[catch {
988        cd $data(selectPath)
989    }]} {
990        # We cannot change directory to $data(selectPath). $data(selectPath)
991        # should have been checked before tkFDialog_Update is called, so
992        # we normally won't come to here. Anyways, give an error and abort
993        # action.
994        tk_messageBox -type ok -parent $data(-parent) -message \
995            "Cannot change to the directory \"$data(selectPath)\".\nPermission denied."\
996            -icon warning
997        cd $appPWD
998        return
999    }
1000
1001    # Turn on the busy cursor. BUG?? We haven't disabled X events, though,
1002    # so the user may still click and cause havoc ...
1003    #
1004    set entCursor [$data(ent) cget -cursor]
1005    set dlgCursor [$w         cget -cursor]
1006    $data(ent) config -cursor watch
1007    $w         config -cursor watch
1008    update idletasks
1009   
1010    tkIconList_DeleteAll $data(icons)
1011
1012    # Make the dir list
1013    #
1014    foreach f [lsort -dictionary [glob -nocomplain .* *]] {
1015        if {![string compare $f .]} {
1016            continue
1017        }
1018        if {![string compare $f ..]} {
1019            continue
1020        }
1021        if {[file isdir ./$f]} {
1022            if {![info exists hasDoneDir($f)]} {
1023                tkIconList_Add $data(icons) $folder $f
1024                set hasDoneDir($f) 1
1025            }
1026        }
1027    }
1028    # Make the file list
1029    #
1030    if {![string compare $data(filter) *]} {
1031        set files [lsort -dictionary \
1032            [glob -nocomplain .* *]]
1033    } else {
1034        set files [lsort -dictionary \
1035            [eval glob -nocomplain $data(filter)]]
1036    }
1037
1038    set top 0
1039    foreach f $files {
1040        if {![file isdir ./$f]} {
1041            if {![info exists hasDoneFile($f)]} {
1042                tkIconList_Add $data(icons) $file $f
1043                set hasDoneFile($f) 1
1044            }
1045        }
1046    }
1047
1048    tkIconList_Arrange $data(icons)
1049
1050    # Update the Directory: option menu
1051    #
1052    set list ""
1053    set dir ""
1054    foreach subdir [file split $data(selectPath)] {
1055        set dir [file join $dir $subdir]
1056        lappend list $dir
1057    }
1058
1059    $data(dirMenu) delete 0 end
1060    set var [format %s(selectPath) $dataName]
1061    foreach path $list {
1062        $data(dirMenu) add command -label $path -command [list set $var $path]
1063    }
1064
1065    # Restore the PWD to the application's PWD
1066    #
1067    cd $appPWD
1068
1069    # turn off the busy cursor.
1070    #
1071    $data(ent) config -cursor $entCursor
1072    $w         config -cursor $dlgCursor
1073}
1074
1075# tkFDialog_SetPathSilently --
1076#
1077#       Sets data(selectPath) without invoking the trace procedure
1078#
1079proc tkFDialog_SetPathSilently {w path} {
1080    upvar #0 [winfo name $w] data
1081   
1082    trace vdelete  data(selectPath) w "tkFDialog_SetPath $w"
1083    set data(selectPath) $path
1084    trace variable data(selectPath) w "tkFDialog_SetPath $w"
1085}
1086
1087
1088# This proc gets called whenever data(selectPath) is set
1089#
1090proc tkFDialog_SetPath {w name1 name2 op} {
1091    if {[winfo exists $w]} {
1092        upvar #0 [winfo name $w] data
1093        tkFDialog_UpdateWhenIdle $w
1094    }
1095}
1096
1097# This proc gets called whenever data(filter) is set
1098#
1099proc tkFDialog_SetFilter {w type} {
1100    upvar #0 [winfo name $w] data
1101    upvar \#0 $data(icons) icons
1102
1103    set data(filter) [lindex $type 1]
1104    $data(typeMenuBtn) config -text [lindex $type 0] -indicatoron 1
1105
1106    $icons(sbar) set 0.0 0.0
1107   
1108    tkFDialog_UpdateWhenIdle $w
1109}
1110
1111# tkFDialogResolveFile --
1112#
1113#       Interpret the user's text input in a file selection dialog.
1114#       Performs:
1115#
1116#       (1) ~ substitution
1117#       (2) resolve all instances of . and ..
1118#       (3) check for non-existent files/directories
1119#       (4) check for chdir permissions
1120#
1121# Arguments:
1122#       context:  the current directory you are in
1123#       text:     the text entered by the user
1124#       defaultext: the default extension to add to files with no extension
1125#
1126# Return vaue:
1127#       [list $flag $directory $file]
1128#
1129#        flag = OK      : valid input
1130#             = PATTERN : valid directory/pattern
1131#             = PATH    : the directory does not exist
1132#             = FILE    : the directory exists by the file doesn't
1133#                         exist
1134#             = CHDIR   : Cannot change to the directory
1135#             = ERROR   : Invalid entry
1136#
1137#        directory      : valid only if flag = OK or PATTERN or FILE
1138#        file           : valid only if flag = OK or PATTERN
1139#
1140#       directory may not be the same as context, because text may contain
1141#       a subdirectory name
1142#
1143proc tkFDialogResolveFile {context text defaultext} {
1144
1145    set appPWD [pwd]
1146
1147    set path [tkFDialog_JoinFile $context $text]
1148
1149    if {[file ext $path] == ""} {
1150        set path "$path$defaultext"
1151    }
1152
1153
1154    if {[catch {file exists $path}]} {
1155        # This "if" block can be safely removed if the following code
1156        # stop generating errors.
1157        #
1158        #       file exists ~nonsuchuser
1159        #
1160        return [list ERROR $path ""]
1161    }
1162
1163    if {[file exists $path]} {
1164        if {[file isdirectory $path]} {
1165            if {[catch {
1166                cd $path
1167            }]} {
1168                return [list CHDIR $path ""]
1169            }
1170            set directory [pwd]
1171            set file ""
1172            set flag OK
1173            cd $appPWD
1174        } else {
1175            if {[catch {
1176                cd [file dirname $path]
1177            }]} {
1178                return [list CHDIR [file dirname $path] ""]
1179            }
1180            set directory [pwd]
1181            set file [file tail $path]
1182            set flag OK
1183            cd $appPWD
1184        }
1185    } else {
1186        set dirname [file dirname $path]
1187        if {[file exists $dirname]} {
1188            if {[catch {
1189                cd $dirname
1190            }]} {
1191                return [list CHDIR $dirname ""]
1192            }
1193            set directory [pwd]
1194            set file [file tail $path]
1195            if {[regexp {[*]|[?]} $file]} {
1196                set flag PATTERN
1197            } else {
1198                set flag FILE
1199            }
1200            cd $appPWD
1201        } else {
1202            set directory $dirname
1203            set file [file tail $path]
1204            set flag PATH
1205        }
1206    }
1207
1208    return [list $flag $directory $file]
1209}
1210
1211
1212# Gets called when the entry box gets keyboard focus. We clear the selection
1213# from the icon list . This way the user can be certain that the input in the
1214# entry box is the selection.
1215#
1216proc tkFDialog_EntFocusIn {w} {
1217    upvar #0 [winfo name $w] data
1218
1219    if {[string compare [$data(ent) get] ""]} {
1220        $data(ent) selection from 0
1221        $data(ent) selection to   end
1222        $data(ent) icursor end
1223    } else {
1224        $data(ent) selection clear
1225    }
1226
1227    tkIconList_Unselect $data(icons)
1228
1229    if {![string compare $data(type) open]} {
1230        $data(okBtn) config -text "Open"
1231    } else {
1232        $data(okBtn) config -text "Save"
1233    }
1234}
1235
1236proc tkFDialog_EntFocusOut {w} {
1237    upvar #0 [winfo name $w] data
1238
1239    $data(ent) selection clear
1240}
1241
1242
1243# Gets called when user presses Return in the "File name" entry.
1244#
1245proc tkFDialog_ActivateEnt {w} {
1246    upvar #0 [winfo name $w] data
1247
1248    set text [string trim [$data(ent) get]]
1249    set list [tkFDialogResolveFile $data(selectPath) $text \
1250                  $data(-defaultextension)]
1251    set flag [lindex $list 0]
1252    set path [lindex $list 1]
1253    set file [lindex $list 2]
1254
1255    case $flag {
1256        OK {
1257            if {![string compare $file ""]} {
1258                # user has entered an existing (sub)directory
1259                set data(selectPath) $path
1260                $data(ent) delete 0 end
1261            } else {
1262                tkFDialog_SetPathSilently $w $path
1263                set data(selectFile) $file
1264                tkFDialog_Done $w
1265            }
1266        }
1267        PATTERN {
1268            set data(selectPath) $path
1269            set data(filter) $file
1270        }
1271        FILE {
1272            if {![string compare $data(type) open]} {
1273                tk_messageBox -icon warning -type ok -parent $data(-parent) \
1274                    -message "File \"[file join $path $file]\" does not exist."
1275                $data(ent) select from 0
1276                $data(ent) select to   end
1277                $data(ent) icursor end
1278            } else {
1279                tkFDialog_SetPathSilently $w $path
1280                set data(selectFile) $file
1281                tkFDialog_Done $w
1282            }
1283        }
1284        PATH {
1285            tk_messageBox -icon warning -type ok -parent $data(-parent) \
1286                -message "Directory \"$path\" does not exist."
1287            $data(ent) select from 0
1288            $data(ent) select to   end
1289            $data(ent) icursor end
1290        }
1291        CHDIR {
1292            tk_messageBox -type ok -parent $data(-parent) -message \
1293               "Cannot change to the directory \"$path\".\nPermission denied."\
1294                -icon warning
1295            $data(ent) select from 0
1296            $data(ent) select to   end
1297            $data(ent) icursor end
1298        }
1299        ERROR {
1300            tk_messageBox -type ok -parent $data(-parent) -message \
1301               "Invalid file name \"$path\"."\
1302                -icon warning
1303            $data(ent) select from 0
1304            $data(ent) select to   end
1305            $data(ent) icursor end
1306        }
1307    }
1308}
1309
1310# Gets called when user presses the Alt-s or Alt-o keys.
1311#
1312proc tkFDialog_InvokeBtn {w key} {
1313    upvar #0 [winfo name $w] data
1314
1315    if {![string compare [$data(okBtn) cget -text] $key]} {
1316        tkButtonInvoke $data(okBtn)
1317    }
1318}
1319
1320# Gets called when user presses the "parent directory" button
1321#
1322proc tkFDialog_UpDirCmd {w} {
1323    upvar #0 [winfo name $w] data
1324
1325    if {[string compare $data(selectPath) "/"]} {
1326        set data(selectPath) [file dirname $data(selectPath)]
1327    }
1328}
1329
1330# Join a file name to a path name. The "file join" command will break
1331# if the filename begins with ~
1332#
1333proc tkFDialog_JoinFile {path file} {
1334    if {[string match {~*} $file] && [file exists $path/$file]} {
1335        return [file join $path ./$file]
1336    } else {
1337        return [file join $path $file]
1338    }
1339}
1340
1341
1342
1343# Gets called when user presses the "OK" button
1344#
1345proc tkFDialog_OkCmd {w} {
1346    upvar #0 [winfo name $w] data
1347
1348    set text [tkIconList_Get $data(icons)]
1349    if {[string compare $text ""]} {
1350        set file [tkFDialog_JoinFile $data(selectPath) $text]
1351        if {[file isdirectory $file]} {
1352            tkFDialog_ListInvoke $w $text
1353            return
1354        }
1355    }
1356
1357    tkFDialog_ActivateEnt $w
1358}
1359
1360# Gets called when user presses the "Cancel" button
1361#
1362proc tkFDialog_CancelCmd {w} {
1363    upvar #0 [winfo name $w] data
1364    global tkPriv
1365
1366    set tkPriv(selectFilePath) ""
1367}
1368
1369# Gets called when user browses the IconList widget (dragging mouse, arrow
1370# keys, etc)
1371#
1372proc tkFDialog_ListBrowse {w text} {
1373    upvar #0 [winfo name $w] data
1374
1375    if {$text == ""} {
1376        return
1377    }
1378
1379    set file [tkFDialog_JoinFile $data(selectPath) $text]
1380    if {![file isdirectory $file]} {
1381        $data(ent) delete 0 end
1382        $data(ent) insert 0 $text
1383
1384        if {![string compare $data(type) open]} {
1385            $data(okBtn) config -text "Open"
1386        } else {
1387            $data(okBtn) config -text "Save"
1388        }
1389    } else {
1390        $data(okBtn) config -text "Open"
1391    }
1392}
1393
1394# Gets called when user invokes the IconList widget (double-click,
1395# Return key, etc)
1396#
1397proc tkFDialog_ListInvoke {w text} {
1398    upvar #0 [winfo name $w] data
1399
1400    if {$text == ""} {
1401        return
1402    }
1403
1404    set file [tkFDialog_JoinFile $data(selectPath) $text]
1405
1406    if {[file isdirectory $file]} {
1407        set appPWD [pwd]
1408        if {[catch {cd $file}]} {
1409            tk_messageBox -type ok -parent $data(-parent) -message \
1410               "Cannot change to the directory \"$file\".\nPermission denied."\
1411                -icon warning
1412        } else {
1413            cd $appPWD
1414            set data(selectPath) $file
1415        }
1416    } else {
1417        set data(selectFile) $file
1418        tkFDialog_Done $w
1419    }
1420}
1421
1422# tkFDialog_Done --
1423#
1424#       Gets called when user has input a valid filename.  Pops up a
1425#       dialog box to confirm selection when necessary. Sets the
1426#       tkPriv(selectFilePath) variable, which will break the "tkwait"
1427#       loop in tkFDialog and return the selected filename to the
1428#       script that calls tk_getOpenFile or tk_getSaveFile
1429#
1430proc tkFDialog_Done {w {selectFilePath ""}} {
1431    upvar #0 [winfo name $w] data
1432    global tkPriv
1433
1434    if {![string compare $selectFilePath ""]} {
1435        set selectFilePath [tkFDialog_JoinFile $data(selectPath) \
1436                $data(selectFile)]
1437        set tkPriv(selectFile)     $data(selectFile)
1438        set tkPriv(selectPath)     $data(selectPath)
1439
1440        if {[file exists $selectFilePath] &&
1441            ![string compare $data(type) save]} {
1442
1443                set reply [tk_messageBox -icon warning -type yesno\
1444                        -parent $data(-parent) -message "File\
1445                        \"$selectFilePath\" already exists.\nDo\
1446                        you want to overwrite it?"]
1447                if {![string compare $reply "no"]} {
1448                    return
1449                }
1450        }
1451    }
1452    set tkPriv(selectFilePath) $selectFilePath
1453}
1454
Note: See TracBrowser for help on using the browser.