DirBox.tcl 5.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207
  1. # -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
  2. #
  3. # $Id: DirBox.tcl,v 1.4 2004/03/28 02:44:57 hobbs Exp $
  4. #
  5. # DirBox.tcl --
  6. #
  7. # Implements the tixDirSelectBox widget.
  8. #
  9. # - overrides the -browsecmd and -command options of the
  10. # HList subwidget
  11. #
  12. # Copyright (c) 1993-1999 Ioi Kim Lam.
  13. # Copyright (c) 2000-2001 Tix Project Group.
  14. # Copyright (c) 2004 ActiveState
  15. #
  16. # See the file "license.terms" for information on usage and redistribution
  17. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  18. #
  19. tixWidgetClass tixDirSelectBox {
  20. -classname TixDirSelectBox
  21. -superclass tixPrimitive
  22. -method {
  23. }
  24. -flag {
  25. -command -disablecallback -value
  26. }
  27. -configspec {
  28. {-command command Command ""}
  29. {-disablecallback disableCallback DisableCallback 0 tixVerifyBoolean}
  30. {-label label Label "Directory:"}
  31. {-value value Value ""}
  32. }
  33. -forcecall {
  34. -value -label
  35. }
  36. -default {
  37. {*combo*listbox.height 5}
  38. {*combo.label.anchor w}
  39. {*combo.labelSide top}
  40. {*combo.history true}
  41. {*combo.historyLimit 20}
  42. }
  43. }
  44. proc tixDirSelectBox:InitWidgetRec {w} {
  45. upvar #0 $w data
  46. tixChainMethod $w InitWidgetRec
  47. }
  48. proc tixDirSelectBox:ConstructWidget {w} {
  49. upvar #0 $w data
  50. tixChainMethod $w ConstructWidget
  51. set data(w:dircbx) [tixFileComboBox $w.dircbx]
  52. set data(w:dirlist) [tixDirList $w.dirlist]
  53. pack $data(w:dircbx) -side top -fill x -padx 4 -pady 2
  54. pack $data(w:dirlist) -side top -fill both -expand yes -padx 4 -pady 2
  55. if {$data(-value) eq ""} {
  56. set data(-value) [pwd]
  57. }
  58. }
  59. proc tixDirSelectBox:SetBindings {w} {
  60. upvar #0 $w data
  61. tixChainMethod $w SetBindings
  62. $data(w:dircbx) config -command [list tixDirSelectBox:Cmd-DirCbx $w]
  63. $data(w:dirlist) config -command [list tixDirSelectBox:Cmd-DirList $w]\
  64. -browsecmd [list tixDirSelectBox:Browse-DirList $w]
  65. }
  66. #----------------------------------------------------------------------
  67. # Incoming event: User
  68. #----------------------------------------------------------------------
  69. # User activates the FileComboBox
  70. #
  71. #
  72. proc tixDirSelectBox:Cmd-DirCbx {w args} {
  73. upvar #0 $w data
  74. set fInfo [tixEvent value]
  75. set path [lindex $fInfo 0]
  76. if {![file exists $path]} {
  77. # 1.1 Check for validity. The pathname cannot contain invalid chars
  78. #
  79. if {![tixFSIsValid $path]} {
  80. tk_messageBox -title "Invalid Directory" \
  81. -type ok -icon error \
  82. -message "\"$path\" is not a valid directory name"
  83. $data(w:dircbx) config \
  84. -text [tixFSDisplayName [file normalize $data(-value)]] \
  85. -directory $data(-value)
  86. return
  87. }
  88. # 1.2 Prompt for creation
  89. #
  90. set choice [tk_messageBox -title "Create Directory?" \
  91. -type yesno -icon question \
  92. -message "Directory \"$path\" does not exist.\
  93. \nDo you want to create it?"]
  94. if {$choice eq "yes"
  95. && [catch {file mkdir [file dirname $path]} err]} {
  96. tk_messageBox -title "Error Creating Directory" \
  97. -icon error -type ok \
  98. -message "Cannot create directory \"$path\":\n$err"
  99. set choice "no"
  100. }
  101. if {$choice eq "no"} {
  102. $data(w:dircbx) config \
  103. -text [tixFSDisplayName [file normalize $data(-value)]] \
  104. -directory $data(-value)
  105. return
  106. }
  107. tixDirSelectBox:SetValue $w $path 1 1
  108. } elseif {![file isdirectory $path]} {
  109. # 2.1: Can't choose a non-directory file
  110. #
  111. tk_messageBox -title "Invalid Directory" \
  112. -type ok -icon error \
  113. -message "\"$path\" is not a directory"
  114. $data(w:dircbx) config \
  115. -text [tixFSDisplayName [file normalize $data(-value)]] \
  116. -directory $data(-value)
  117. return
  118. } else {
  119. # OK. It is an existing directory
  120. #
  121. tixDirSelectBox:SetValue $w $path 1 1
  122. }
  123. }
  124. # User activates the dir list
  125. #
  126. #
  127. proc tixDirSelectBox:Cmd-DirList {w args} {
  128. upvar #0 $w data
  129. set dir $data(-value)
  130. catch {set dir [tixEvent flag V]}
  131. set dir [tixFSNormalize $dir]
  132. tixDirSelectBox:SetValue $w $dir 0 0
  133. }
  134. # User browses the dir list
  135. #
  136. #
  137. proc tixDirSelectBox:Browse-DirList {w args} {
  138. upvar #0 $w data
  139. set dir $data(-value)
  140. catch {set dir [tixEvent flag V]}
  141. set dir [tixFSNormalize $dir]
  142. tixDirSelectBox:SetValue $w $dir 0 0
  143. }
  144. #----------------------------------------------------------------------
  145. # Incoming event: Application
  146. #----------------------------------------------------------------------
  147. proc tixDirSelectBox:config-value {w value} {
  148. upvar #0 $w data
  149. set value [tixFSNormalize $value]
  150. tixDirSelectBox:SetValue $w $value 1 1
  151. return $value
  152. }
  153. proc tixDirSelectBox:config-label {w value} {
  154. upvar #0 $w data
  155. $data(w:dircbx) subwidget combo config -label $value
  156. }
  157. #----------------------------------------------------------------------
  158. #
  159. # Internal functions
  160. #
  161. #----------------------------------------------------------------------
  162. # Arguments:
  163. # callback:Bool Should we invoke the the -command.
  164. # setlist:Bool Should we set the -value of the DirList subwidget.
  165. #
  166. proc tixDirSelectBox:SetValue {w dir callback setlist} {
  167. upvar #0 $w data
  168. set data(-value) $dir
  169. $data(w:dircbx) config -text [tixFSDisplayName $dir] -directory $dir
  170. if {$setlist && [file isdirectory $dir]} {
  171. tixSetSilent $data(w:dirlist) $dir
  172. }
  173. if {$callback} {
  174. if {!$data(-disablecallback) && [llength $data(-command)]} {
  175. set bind(specs) {%V}
  176. set bind(%V) $data(-value)
  177. tixEvalCmdBinding $w $data(-command) bind $data(-value)
  178. }
  179. }
  180. }