home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / comanche.exe / lib / tk8.0 / tkfbox.tcl < prev    next >
Text File  |  1999-02-24  |  38KB  |  1,457 lines
  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. # RCS: @(#) $Id: tkfbox.tcl,v 1.8 1998/11/12 06:22:05 welch Exp $
  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. #
  35. proc 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. #
  47. proc 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. #
  68. proc 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. #
  128. proc 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. #
  158. proc 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. #
  180. proc 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. #
  218. proc 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. #
  308. proc 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.
  320. proc 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.  
  369. proc 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.  
  376. proc 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.  
  406. proc 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. #
  421. proc 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.  
  432. proc 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. #
  441. proc 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.  
  449. proc tkIconList_Double1 {w x y} {
  450.     upvar #0 $w data
  451.  
  452.     if {$data(curItem) != {}} {
  453.     tkIconList_Invoke $w
  454.     }
  455. }
  456.  
  457. proc tkIconList_ReturnKey {w} {
  458.     tkIconList_Invoke $w
  459. }
  460.  
  461. proc 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.  
  469. proc 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. #
  490. proc 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. #
  521. proc 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. #
  552. proc 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.  
  563. proc 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.  
  613. proc 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. #
  631. proc 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. #
  745. proc 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.  
  810. proc 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 {
  826. #define updir_width 28
  827. #define updir_height 16
  828. static char updir_bits[] = {
  829.    0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
  830.    0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
  831.    0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
  832.    0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
  833.    0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
  834.    0xf0, 0xff, 0xff, 0x01};}]
  835.     }
  836.     $data(upBtn) config -image $tkPriv(updirImage)
  837.  
  838.     $f1.menu config -takefocus 1 -highlightthickness 2
  839.  
  840.     pack $data(upBtn) -side right -padx 4 -fill both
  841.     pack $f1.lab -side left -padx 4 -fill both
  842.     pack $f1.menu -expand yes -fill both -padx 4
  843.  
  844.     # data(icons): the IconList that list the files and directories.
  845.     #
  846.     set data(icons) [tkIconList $w.icons \
  847.     -browsecmd "tkFDialog_ListBrowse $w" \
  848.     -command   "tkFDialog_OkCmd $w"]
  849.  
  850.     # f2: the frame with the OK button and the "file name" field
  851.     #
  852.     set f2 [frame $w.f2 -bd 0]
  853.     label $f2.lab -text "File name:" -anchor e -width 14 -under 5 -pady 0
  854.     set data(ent) [entry $f2.ent]
  855.  
  856.     # The font to use for the icons. The default Canvas font on Unix
  857.     # is just deviant.
  858.     global $w.icons
  859.     set $w.icons(font) [$data(ent) cget -font]
  860.  
  861.     # f3: the frame with the cancel button and the file types field
  862.     #
  863.     set f3 [frame $w.f3 -bd 0]
  864.  
  865.     # The "File of types:" label needs to be grayed-out when
  866.     # -filetypes are not specified. The label widget does not support
  867.     # grayed-out text on monochrome displays. Therefore, we have to
  868.     # use a button widget to emulate a label widget (by setting its
  869.     # bindtags)
  870.  
  871.     set data(typeMenuLab) [button $f3.lab -text "Files of type:" \
  872.     -anchor e -width 14 -under 9 \
  873.     -bd [$f2.lab cget -bd] \
  874.     -highlightthickness [$f2.lab cget -highlightthickness] \
  875.     -relief [$f2.lab cget -relief] \
  876.     -padx [$f2.lab cget -padx] \
  877.     -pady [$f2.lab cget -pady]]
  878.     bindtags $data(typeMenuLab) [list $data(typeMenuLab) Label \
  879.         [winfo toplevel $data(typeMenuLab)] all]
  880.  
  881.     set data(typeMenuBtn) [menubutton $f3.menu -indicatoron 1 -menu $f3.menu.m]
  882.     set data(typeMenu) [menu $data(typeMenuBtn).m -tearoff 0]
  883.     $data(typeMenuBtn) config -takefocus 1 -highlightthickness 2 \
  884.     -relief raised -bd 2 -anchor w
  885.  
  886.     # the okBtn is created after the typeMenu so that the keyboard traversal
  887.     # is in the right order
  888.     set data(okBtn)     [button $f2.ok     -text OK     -under 0 -width 6 \
  889.     -default active -pady 3]
  890.     set data(cancelBtn) [button $f3.cancel -text Cancel -under 0 -width 6\
  891.     -default normal -pady 3]
  892.  
  893.     # pack the widgets in f2 and f3
  894.     #
  895.     pack $data(okBtn) -side right -padx 4 -anchor e
  896.     pack $f2.lab -side left -padx 4
  897.     pack $f2.ent -expand yes -fill x -padx 2 -pady 0
  898.     
  899.     pack $data(cancelBtn) -side right -padx 4 -anchor w
  900.     pack $data(typeMenuLab) -side left -padx 4
  901.     pack $data(typeMenuBtn) -expand yes -fill x -side right
  902.  
  903.     # Pack all the frames together. We are done with widget construction.
  904.     #
  905.     pack $f1 -side top -fill x -pady 4
  906.     pack $f3 -side bottom -fill x
  907.     pack $f2 -side bottom -fill x
  908.     pack $data(icons) -expand yes -fill both -padx 4 -pady 1
  909.  
  910.     # Set up the event handlers
  911.     #
  912.     bind $data(ent) <Return>  "tkFDialog_ActivateEnt $w"
  913.     
  914.     $data(upBtn)     config -command "tkFDialog_UpDirCmd $w"
  915.     $data(okBtn)     config -command "tkFDialog_OkCmd $w"
  916.     $data(cancelBtn) config -command "tkFDialog_CancelCmd $w"
  917.  
  918.     trace variable data(selectPath) w "tkFDialog_SetPath $w"
  919.  
  920.     bind $w <Alt-d> "focus $data(dirMenuBtn)"
  921.     bind $w <Alt-t> [format {
  922.     if {"[%s cget -state]" == "normal"} {
  923.         focus %s
  924.     }
  925.     } $data(typeMenuBtn) $data(typeMenuBtn)]
  926.     bind $w <Alt-n> "focus $data(ent)"
  927.     bind $w <KeyPress-Escape> "tkButtonInvoke $data(cancelBtn)"
  928.     bind $w <Alt-c> "tkButtonInvoke $data(cancelBtn)"
  929.     bind $w <Alt-o> "tkFDialog_InvokeBtn $w Open"
  930.     bind $w <Alt-s> "tkFDialog_InvokeBtn $w Save"
  931.  
  932.     wm protocol $w WM_DELETE_WINDOW "tkFDialog_CancelCmd $w"
  933.  
  934.     # Build the focus group for all the entries
  935.     #
  936.     tkFocusGroup_Create $w
  937.     tkFocusGroup_BindIn $w  $data(ent) "tkFDialog_EntFocusIn $w"
  938.     tkFocusGroup_BindOut $w $data(ent) "tkFDialog_EntFocusOut $w"
  939. }
  940.  
  941. # tkFDialog_UpdateWhenIdle --
  942. #
  943. #    Creates an idle event handler which updates the dialog in idle
  944. #    time. This is important because loading the directory may take a long
  945. #    time and we don't want to load the same directory for multiple times
  946. #    due to multiple concurrent events.
  947. #
  948. proc tkFDialog_UpdateWhenIdle {w} {
  949.     upvar #0 [winfo name $w] data
  950.  
  951.     if {[info exists data(updateId)]} {
  952.     return
  953.     } else {
  954.     set data(updateId) [after idle tkFDialog_Update $w]
  955.     }
  956. }
  957.  
  958. # tkFDialog_Update --
  959. #
  960. #    Loads the files and directories into the IconList widget. Also
  961. #    sets up the directory option menu for quick access to parent
  962. #    directories.
  963. #
  964. proc tkFDialog_Update {w} {
  965.  
  966.     # This proc may be called within an idle handler. Make sure that the
  967.     # window has not been destroyed before this proc is called
  968.     if {![winfo exists $w] || [string compare [winfo class $w] TkFDialog]} {
  969.     return
  970.     }
  971.  
  972.     set dataName [winfo name $w]
  973.     upvar #0 $dataName data
  974.     global tk_library tkPriv
  975.     catch {unset data(updateId)}
  976.  
  977.     if {![info exists tkPriv(folderImage)]} {
  978.     set tkPriv(folderImage) [image create photo -data {
  979. R0lGODlhEAAMAKEAAAD//wAAAPD/gAAAACH5BAEAAAAALAAAAAAQAAwAAAIghINhyycvVFsB
  980. QtmS3rjaH1Hg141WaT5ouprt2HHcUgAAOw==}]
  981.     set tkPriv(fileImage)   [image create photo -data {
  982. R0lGODlhDAAMAKEAALLA3AAAAP//8wAAACH5BAEAAAAALAAAAAAMAAwAAAIgRI4Ha+IfWHsO
  983. rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}]
  984.     }
  985.     set folder $tkPriv(folderImage)
  986.     set file   $tkPriv(fileImage)
  987.  
  988.     set appPWD [pwd]
  989.     if {[catch {
  990.     cd $data(selectPath)
  991.     }]} {
  992.     # We cannot change directory to $data(selectPath). $data(selectPath)
  993.     # should have been checked before tkFDialog_Update is called, so
  994.     # we normally won't come to here. Anyways, give an error and abort
  995.     # action.
  996.     tk_messageBox -type ok -parent $data(-parent) -message \
  997.         "Cannot change to the directory \"$data(selectPath)\".\nPermission denied."\
  998.         -icon warning
  999.     cd $appPWD
  1000.     return
  1001.     }
  1002.  
  1003.     # Turn on the busy cursor. BUG?? We haven't disabled X events, though,
  1004.     # so the user may still click and cause havoc ...
  1005.     #
  1006.     set entCursor [$data(ent) cget -cursor]
  1007.     set dlgCursor [$w         cget -cursor]
  1008.     $data(ent) config -cursor watch
  1009.     $w         config -cursor watch
  1010.     update idletasks
  1011.     
  1012.     tkIconList_DeleteAll $data(icons)
  1013.  
  1014.     # Make the dir list
  1015.     #
  1016.     foreach f [lsort -dictionary [glob -nocomplain .* *]] {
  1017.     if {![string compare $f .]} {
  1018.         continue
  1019.     }
  1020.     if {![string compare $f ..]} {
  1021.         continue
  1022.     }
  1023.     if {[file isdir ./$f]} {
  1024.         if {![info exists hasDoneDir($f)]} {
  1025.         tkIconList_Add $data(icons) $folder $f
  1026.         set hasDoneDir($f) 1
  1027.         }
  1028.     }
  1029.     }
  1030.     # Make the file list
  1031.     #
  1032.     if {![string compare $data(filter) *]} {
  1033.     set files [lsort -dictionary \
  1034.         [glob -nocomplain .* *]]
  1035.     } else {
  1036.     set files [lsort -dictionary \
  1037.         [eval glob -nocomplain $data(filter)]]
  1038.     }
  1039.  
  1040.     set top 0
  1041.     foreach f $files {
  1042.     if {![file isdir ./$f]} {
  1043.         if {![info exists hasDoneFile($f)]} {
  1044.         tkIconList_Add $data(icons) $file $f
  1045.         set hasDoneFile($f) 1
  1046.         }
  1047.     }
  1048.     }
  1049.  
  1050.     tkIconList_Arrange $data(icons)
  1051.  
  1052.     # Update the Directory: option menu
  1053.     #
  1054.     set list ""
  1055.     set dir ""
  1056.     foreach subdir [file split $data(selectPath)] {
  1057.     set dir [file join $dir $subdir]
  1058.     lappend list $dir
  1059.     }
  1060.  
  1061.     $data(dirMenu) delete 0 end
  1062.     set var [format %s(selectPath) $dataName]
  1063.     foreach path $list {
  1064.     $data(dirMenu) add command -label $path -command [list set $var $path]
  1065.     }
  1066.  
  1067.     # Restore the PWD to the application's PWD
  1068.     #
  1069.     cd $appPWD
  1070.  
  1071.     # turn off the busy cursor.
  1072.     #
  1073.     $data(ent) config -cursor $entCursor
  1074.     $w         config -cursor $dlgCursor
  1075. }
  1076.  
  1077. # tkFDialog_SetPathSilently --
  1078. #
  1079. #     Sets data(selectPath) without invoking the trace procedure
  1080. #
  1081. proc tkFDialog_SetPathSilently {w path} {
  1082.     upvar #0 [winfo name $w] data
  1083.     
  1084.     trace vdelete  data(selectPath) w "tkFDialog_SetPath $w"
  1085.     set data(selectPath) $path
  1086.     trace variable data(selectPath) w "tkFDialog_SetPath $w"
  1087. }
  1088.  
  1089.  
  1090. # This proc gets called whenever data(selectPath) is set
  1091. #
  1092. proc tkFDialog_SetPath {w name1 name2 op} {
  1093.     if {[winfo exists $w]} {
  1094.     upvar #0 [winfo name $w] data
  1095.     tkFDialog_UpdateWhenIdle $w
  1096.     }
  1097. }
  1098.  
  1099. # This proc gets called whenever data(filter) is set
  1100. #
  1101. proc tkFDialog_SetFilter {w type} {
  1102.     upvar #0 [winfo name $w] data
  1103.     upvar \#0 $data(icons) icons
  1104.  
  1105.     set data(filter) [lindex $type 1]
  1106.     $data(typeMenuBtn) config -text [lindex $type 0] -indicatoron 1
  1107.  
  1108.     $icons(sbar) set 0.0 0.0
  1109.     
  1110.     tkFDialog_UpdateWhenIdle $w
  1111. }
  1112.  
  1113. # tkFDialogResolveFile --
  1114. #
  1115. #    Interpret the user's text input in a file selection dialog.
  1116. #    Performs:
  1117. #
  1118. #    (1) ~ substitution
  1119. #    (2) resolve all instances of . and ..
  1120. #    (3) check for non-existent files/directories
  1121. #    (4) check for chdir permissions
  1122. #
  1123. # Arguments:
  1124. #    context:  the current directory you are in
  1125. #    text:      the text entered by the user
  1126. #    defaultext: the default extension to add to files with no extension
  1127. #
  1128. # Return vaue:
  1129. #    [list $flag $directory $file]
  1130. #
  1131. #     flag = OK    : valid input
  1132. #          = PATTERN    : valid directory/pattern
  1133. #          = PATH    : the directory does not exist
  1134. #          = FILE    : the directory exists by the file doesn't
  1135. #              exist
  1136. #          = CHDIR    : Cannot change to the directory
  1137. #          = ERROR    : Invalid entry
  1138. #
  1139. #     directory      : valid only if flag = OK or PATTERN or FILE
  1140. #     file           : valid only if flag = OK or PATTERN
  1141. #
  1142. #    directory may not be the same as context, because text may contain
  1143. #    a subdirectory name
  1144. #
  1145. proc tkFDialogResolveFile {context text defaultext} {
  1146.  
  1147.     set appPWD [pwd]
  1148.  
  1149.     set path [tkFDialog_JoinFile $context $text]
  1150.  
  1151.     if {[file ext $path] == ""} {
  1152.     set path "$path$defaultext"
  1153.     }
  1154.  
  1155.  
  1156.     if {[catch {file exists $path}]} {
  1157.     # This "if" block can be safely removed if the following code
  1158.     # stop generating errors.
  1159.     #
  1160.     #    file exists ~nonsuchuser
  1161.     #
  1162.     return [list ERROR $path ""]
  1163.     }
  1164.  
  1165.     if {[file exists $path]} {
  1166.     if {[file isdirectory $path]} {
  1167.         if {[catch {
  1168.         cd $path
  1169.         }]} {
  1170.         return [list CHDIR $path ""]
  1171.         }
  1172.         set directory [pwd]
  1173.         set file ""
  1174.         set flag OK
  1175.         cd $appPWD
  1176.     } else {
  1177.         if {[catch {
  1178.         cd [file dirname $path]
  1179.         }]} {
  1180.         return [list CHDIR [file dirname $path] ""]
  1181.         }
  1182.         set directory [pwd]
  1183.         set file [file tail $path]
  1184.         set flag OK
  1185.         cd $appPWD
  1186.     }
  1187.     } else {
  1188.     set dirname [file dirname $path]
  1189.     if {[file exists $dirname]} {
  1190.         if {[catch {
  1191.         cd $dirname
  1192.         }]} {
  1193.         return [list CHDIR $dirname ""]
  1194.         }
  1195.         set directory [pwd]
  1196.         set file [file tail $path]
  1197.         if {[regexp {[*]|[?]} $file]} {
  1198.         set flag PATTERN
  1199.         } else {
  1200.         set flag FILE
  1201.         }
  1202.         cd $appPWD
  1203.     } else {
  1204.         set directory $dirname
  1205.         set file [file tail $path]
  1206.         set flag PATH
  1207.     }
  1208.     }
  1209.  
  1210.     return [list $flag $directory $file]
  1211. }
  1212.  
  1213.  
  1214. # Gets called when the entry box gets keyboard focus. We clear the selection
  1215. # from the icon list . This way the user can be certain that the input in the 
  1216. # entry box is the selection.
  1217. #
  1218. proc tkFDialog_EntFocusIn {w} {
  1219.     upvar #0 [winfo name $w] data
  1220.  
  1221.     if {[string compare [$data(ent) get] ""]} {
  1222.     $data(ent) selection from 0
  1223.     $data(ent) selection to   end
  1224.     $data(ent) icursor end
  1225.     } else {
  1226.     $data(ent) selection clear
  1227.     }
  1228.  
  1229.     tkIconList_Unselect $data(icons)
  1230.  
  1231.     if {![string compare $data(type) open]} {
  1232.     $data(okBtn) config -text "Open"
  1233.     } else {
  1234.     $data(okBtn) config -text "Save"
  1235.     }
  1236. }
  1237.  
  1238. proc tkFDialog_EntFocusOut {w} {
  1239.     upvar #0 [winfo name $w] data
  1240.  
  1241.     $data(ent) selection clear
  1242. }
  1243.  
  1244.  
  1245. # Gets called when user presses Return in the "File name" entry.
  1246. #
  1247. proc tkFDialog_ActivateEnt {w} {
  1248.     upvar #0 [winfo name $w] data
  1249.  
  1250.     set text [string trim [$data(ent) get]]
  1251.     set list [tkFDialogResolveFile $data(selectPath) $text \
  1252.           $data(-defaultextension)]
  1253.     set flag [lindex $list 0]
  1254.     set path [lindex $list 1]
  1255.     set file [lindex $list 2]
  1256.  
  1257.     switch -- $flag {
  1258.     OK {
  1259.         if {![string compare $file ""]} {
  1260.         # user has entered an existing (sub)directory
  1261.         set data(selectPath) $path
  1262.         $data(ent) delete 0 end
  1263.         } else {
  1264.         tkFDialog_SetPathSilently $w $path
  1265.         set data(selectFile) $file
  1266.         tkFDialog_Done $w
  1267.         }
  1268.     }
  1269.     PATTERN {
  1270.         set data(selectPath) $path
  1271.         set data(filter) $file
  1272.     }
  1273.     FILE {
  1274.         if {![string compare $data(type) open]} {
  1275.         tk_messageBox -icon warning -type ok -parent $data(-parent) \
  1276.             -message "File \"[file join $path $file]\" does not exist."
  1277.         $data(ent) select from 0
  1278.         $data(ent) select to   end
  1279.         $data(ent) icursor end
  1280.         } else {
  1281.         tkFDialog_SetPathSilently $w $path
  1282.         set data(selectFile) $file
  1283.         tkFDialog_Done $w
  1284.         }
  1285.     }
  1286.     PATH {
  1287.         tk_messageBox -icon warning -type ok -parent $data(-parent) \
  1288.         -message "Directory \"$path\" does not exist."
  1289.         $data(ent) select from 0
  1290.         $data(ent) select to   end
  1291.         $data(ent) icursor end
  1292.     }
  1293.     CHDIR {
  1294.         tk_messageBox -type ok -parent $data(-parent) -message \
  1295.            "Cannot change to the directory \"$path\".\nPermission denied."\
  1296.         -icon warning
  1297.         $data(ent) select from 0
  1298.         $data(ent) select to   end
  1299.         $data(ent) icursor end
  1300.     }
  1301.     ERROR {
  1302.         tk_messageBox -type ok -parent $data(-parent) -message \
  1303.            "Invalid file name \"$path\"."\
  1304.         -icon warning
  1305.         $data(ent) select from 0
  1306.         $data(ent) select to   end
  1307.         $data(ent) icursor end
  1308.     }
  1309.     }
  1310. }
  1311.  
  1312. # Gets called when user presses the Alt-s or Alt-o keys.
  1313. #
  1314. proc tkFDialog_InvokeBtn {w key} {
  1315.     upvar #0 [winfo name $w] data
  1316.  
  1317.     if {![string compare [$data(okBtn) cget -text] $key]} {
  1318.     tkButtonInvoke $data(okBtn)
  1319.     }
  1320. }
  1321.  
  1322. # Gets called when user presses the "parent directory" button
  1323. #
  1324. proc tkFDialog_UpDirCmd {w} {
  1325.     upvar #0 [winfo name $w] data
  1326.  
  1327.     if {[string compare $data(selectPath) "/"]} {
  1328.     set data(selectPath) [file dirname $data(selectPath)]
  1329.     }
  1330. }
  1331.  
  1332. # Join a file name to a path name. The "file join" command will break
  1333. # if the filename begins with ~
  1334. #
  1335. proc tkFDialog_JoinFile {path file} {
  1336.     if {[string match {~*} $file] && [file exists $path/$file]} {
  1337.     return [file join $path ./$file]
  1338.     } else {
  1339.     return [file join $path $file]
  1340.     }
  1341. }
  1342.  
  1343.  
  1344.  
  1345. # Gets called when user presses the "OK" button
  1346. #
  1347. proc tkFDialog_OkCmd {w} {
  1348.     upvar #0 [winfo name $w] data
  1349.  
  1350.     set text [tkIconList_Get $data(icons)]
  1351.     if {[string compare $text ""]} {
  1352.     set file [tkFDialog_JoinFile $data(selectPath) $text]
  1353.     if {[file isdirectory $file]} {
  1354.         tkFDialog_ListInvoke $w $text
  1355.         return
  1356.     }
  1357.     }
  1358.  
  1359.     tkFDialog_ActivateEnt $w
  1360. }
  1361.  
  1362. # Gets called when user presses the "Cancel" button
  1363. #
  1364. proc tkFDialog_CancelCmd {w} {
  1365.     upvar #0 [winfo name $w] data
  1366.     global tkPriv
  1367.  
  1368.     set tkPriv(selectFilePath) ""
  1369. }
  1370.  
  1371. # Gets called when user browses the IconList widget (dragging mouse, arrow
  1372. # keys, etc)
  1373. #
  1374. proc tkFDialog_ListBrowse {w text} {
  1375.     upvar #0 [winfo name $w] data
  1376.  
  1377.     if {$text == ""} {
  1378.     return
  1379.     }
  1380.  
  1381.     set file [tkFDialog_JoinFile $data(selectPath) $text]
  1382.     if {![file isdirectory $file]} {
  1383.     $data(ent) delete 0 end
  1384.     $data(ent) insert 0 $text
  1385.  
  1386.     if {![string compare $data(type) open]} {
  1387.         $data(okBtn) config -text "Open"
  1388.     } else {
  1389.         $data(okBtn) config -text "Save"
  1390.     }
  1391.     } else {
  1392.     $data(okBtn) config -text "Open"
  1393.     }
  1394. }
  1395.  
  1396. # Gets called when user invokes the IconList widget (double-click, 
  1397. # Return key, etc)
  1398. #
  1399. proc tkFDialog_ListInvoke {w text} {
  1400.     upvar #0 [winfo name $w] data
  1401.  
  1402.     if {$text == ""} {
  1403.     return
  1404.     }
  1405.  
  1406.     set file [tkFDialog_JoinFile $data(selectPath) $text]
  1407.  
  1408.     if {[file isdirectory $file]} {
  1409.     set appPWD [pwd]
  1410.     if {[catch {cd $file}]} {
  1411.         tk_messageBox -type ok -parent $data(-parent) -message \
  1412.            "Cannot change to the directory \"$file\".\nPermission denied."\
  1413.         -icon warning
  1414.     } else {
  1415.         cd $appPWD
  1416.         set data(selectPath) $file
  1417.     }
  1418.     } else {
  1419.     set data(selectFile) $file
  1420.     tkFDialog_Done $w
  1421.     }
  1422. }
  1423.  
  1424. # tkFDialog_Done --
  1425. #
  1426. #    Gets called when user has input a valid filename.  Pops up a
  1427. #    dialog box to confirm selection when necessary. Sets the
  1428. #    tkPriv(selectFilePath) variable, which will break the "tkwait"
  1429. #    loop in tkFDialog and return the selected filename to the
  1430. #    script that calls tk_getOpenFile or tk_getSaveFile
  1431. #
  1432. proc tkFDialog_Done {w {selectFilePath ""}} {
  1433.     upvar #0 [winfo name $w] data
  1434.     global tkPriv
  1435.  
  1436.     if {![string compare $selectFilePath ""]} {
  1437.     set selectFilePath [tkFDialog_JoinFile $data(selectPath) \
  1438.         $data(selectFile)]
  1439.     set tkPriv(selectFile)     $data(selectFile)
  1440.     set tkPriv(selectPath)     $data(selectPath)
  1441.  
  1442.     if {[file exists $selectFilePath] && 
  1443.         ![string compare $data(type) save]} {
  1444.  
  1445.         set reply [tk_messageBox -icon warning -type yesno\
  1446.             -parent $data(-parent) -message "File\
  1447.             \"$selectFilePath\" already exists.\nDo\
  1448.             you want to overwrite it?"]
  1449.         if {![string compare $reply "no"]} {
  1450.             return
  1451.         }
  1452.     }
  1453.     }
  1454.     set tkPriv(selectFilePath) $selectFilePath
  1455. }
  1456.  
  1457.