comdlg.tcl (8229B)
1 # comdlg.tcl -- 2 # 3 # Some functions needed for the common dialog boxes. Probably need to go 4 # in a different file. 5 # 6 # Copyright (c) 1996 Sun Microsystems, Inc. 7 # 8 # See the file "license.terms" for information on usage and redistribution 9 # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 # 11 12 # tclParseConfigSpec -- 13 # 14 # Parses a list of "-option value" pairs. If all options and 15 # values are legal, the values are stored in 16 # $data($option). Otherwise an error message is returned. When 17 # an error happens, the data() array may have been partially 18 # modified, but all the modified members of the data(0 array are 19 # guaranteed to have valid values. This is different than 20 # Tk_ConfigureWidget() which does not modify the value of a 21 # widget record if any error occurs. 22 # 23 # Arguments: 24 # 25 # w = widget record to modify. Must be the pathname of a widget. 26 # 27 # specs = { 28 # {-commandlineswitch resourceName ResourceClass defaultValue verifier} 29 # {....} 30 # } 31 # 32 # flags = currently unused. 33 # 34 # argList = The list of "-option value" pairs. 35 # 36 proc tclParseConfigSpec {w specs flags argList} { 37 upvar #0 $w data 38 39 # 1: Put the specs in associative arrays for faster access 40 # 41 foreach spec $specs { 42 if {[llength $spec] < 4} { 43 return -code error -errorcode {TK VALUE CONFIG_SPEC} \ 44 "\"spec\" should contain 5 or 4 elements" 45 } 46 set cmdsw [lindex $spec 0] 47 set cmd($cmdsw) "" 48 set rname($cmdsw) [lindex $spec 1] 49 set rclass($cmdsw) [lindex $spec 2] 50 set def($cmdsw) [lindex $spec 3] 51 set verproc($cmdsw) [lindex $spec 4] 52 } 53 54 if {[llength $argList] & 1} { 55 set cmdsw [lindex $argList end] 56 if {![info exists cmd($cmdsw)]} { 57 return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \ 58 "bad option \"$cmdsw\": must be [tclListValidFlags cmd]" 59 } 60 return -code error -errorcode {TK VALUE_MISSING} \ 61 "value for \"$cmdsw\" missing" 62 } 63 64 # 2: set the default values 65 # 66 foreach cmdsw [array names cmd] { 67 set data($cmdsw) $def($cmdsw) 68 } 69 70 # 3: parse the argument list 71 # 72 foreach {cmdsw value} $argList { 73 if {![info exists cmd($cmdsw)]} { 74 return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \ 75 "bad option \"$cmdsw\": must be [tclListValidFlags cmd]" 76 } 77 set data($cmdsw) $value 78 } 79 80 # Done! 81 } 82 83 proc tclListValidFlags {v} { 84 upvar $v cmd 85 86 set len [llength [array names cmd]] 87 set i 1 88 set separator "" 89 set errormsg "" 90 foreach cmdsw [lsort [array names cmd]] { 91 append errormsg "$separator$cmdsw" 92 incr i 93 if {$i == $len} { 94 set separator ", or " 95 } else { 96 set separator ", " 97 } 98 } 99 return $errormsg 100 } 101 102 #---------------------------------------------------------------------- 103 # 104 # Focus Group 105 # 106 # Focus groups are used to handle the user's focusing actions inside a 107 # toplevel. 108 # 109 # One example of using focus groups is: when the user focuses on an 110 # entry, the text in the entry is highlighted and the cursor is put to 111 # the end of the text. When the user changes focus to another widget, 112 # the text in the previously focused entry is validated. 113 # 114 #---------------------------------------------------------------------- 115 116 117 # ::tk::FocusGroup_Create -- 118 # 119 # Create a focus group. All the widgets in a focus group must be 120 # within the same focus toplevel. Each toplevel can have only 121 # one focus group, which is identified by the name of the 122 # toplevel widget. 123 # 124 proc ::tk::FocusGroup_Create {t} { 125 variable ::tk::Priv 126 if {[winfo toplevel $t] ne $t} { 127 return -code error -errorcode [list TK LOOKUP TOPLEVEL $t] \ 128 "$t is not a toplevel window" 129 } 130 if {![info exists Priv(fg,$t)]} { 131 set Priv(fg,$t) 1 132 set Priv(focus,$t) "" 133 bind $t <FocusIn> [list tk::FocusGroup_In $t %W %d] 134 bind $t <FocusOut> [list tk::FocusGroup_Out $t %W %d] 135 bind $t <Destroy> [list tk::FocusGroup_Destroy $t %W] 136 } 137 } 138 139 # ::tk::FocusGroup_BindIn -- 140 # 141 # Add a widget into the "FocusIn" list of the focus group. The $cmd will be 142 # called when the widget is focused on by the user. 143 # 144 proc ::tk::FocusGroup_BindIn {t w cmd} { 145 variable FocusIn 146 variable ::tk::Priv 147 if {![info exists Priv(fg,$t)]} { 148 return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \ 149 "focus group \"$t\" doesn't exist" 150 } 151 set FocusIn($t,$w) $cmd 152 } 153 154 155 # ::tk::FocusGroup_BindOut -- 156 # 157 # Add a widget into the "FocusOut" list of the focus group. The 158 # $cmd will be called when the widget loses the focus (User 159 # types Tab or click on another widget). 160 # 161 proc ::tk::FocusGroup_BindOut {t w cmd} { 162 variable FocusOut 163 variable ::tk::Priv 164 if {![info exists Priv(fg,$t)]} { 165 return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \ 166 "focus group \"$t\" doesn't exist" 167 } 168 set FocusOut($t,$w) $cmd 169 } 170 171 # ::tk::FocusGroup_Destroy -- 172 # 173 # Cleans up when members of the focus group is deleted, or when the 174 # toplevel itself gets deleted. 175 # 176 proc ::tk::FocusGroup_Destroy {t w} { 177 variable FocusIn 178 variable FocusOut 179 variable ::tk::Priv 180 181 if {$t eq $w} { 182 unset Priv(fg,$t) 183 unset Priv(focus,$t) 184 185 foreach name [array names FocusIn $t,*] { 186 unset FocusIn($name) 187 } 188 foreach name [array names FocusOut $t,*] { 189 unset FocusOut($name) 190 } 191 } else { 192 if {[info exists Priv(focus,$t)] && ($Priv(focus,$t) eq $w)} { 193 set Priv(focus,$t) "" 194 } 195 unset -nocomplain FocusIn($t,$w) FocusOut($t,$w) 196 } 197 } 198 199 # ::tk::FocusGroup_In -- 200 # 201 # Handles the <FocusIn> event. Calls the FocusIn command for the newly 202 # focused widget in the focus group. 203 # 204 proc ::tk::FocusGroup_In {t w detail} { 205 variable FocusIn 206 variable ::tk::Priv 207 208 if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} { 209 # This is caused by mouse moving out&in of the window *or* 210 # ordinary keypresses some window managers (ie: CDE [Bug: 2960]). 211 return 212 } 213 if {![info exists FocusIn($t,$w)]} { 214 set FocusIn($t,$w) "" 215 return 216 } 217 if {![info exists Priv(focus,$t)]} { 218 return 219 } 220 if {$Priv(focus,$t) eq $w} { 221 # This is already in focus 222 # 223 return 224 } else { 225 set Priv(focus,$t) $w 226 eval $FocusIn($t,$w) 227 } 228 } 229 230 # ::tk::FocusGroup_Out -- 231 # 232 # Handles the <FocusOut> event. Checks if this is really a lose 233 # focus event, not one generated by the mouse moving out of the 234 # toplevel window. Calls the FocusOut command for the widget 235 # who loses its focus. 236 # 237 proc ::tk::FocusGroup_Out {t w detail} { 238 variable FocusOut 239 variable ::tk::Priv 240 241 if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} { 242 # This is caused by mouse moving out of the window 243 return 244 } 245 if {![info exists Priv(focus,$t)]} { 246 return 247 } 248 if {![info exists FocusOut($t,$w)]} { 249 return 250 } else { 251 eval $FocusOut($t,$w) 252 set Priv(focus,$t) "" 253 } 254 } 255 256 # ::tk::FDGetFileTypes -- 257 # 258 # Process the string given by the -filetypes option of the file 259 # dialogs. Similar to the C function TkGetFileFilters() on the Mac 260 # and Windows platform. 261 # 262 proc ::tk::FDGetFileTypes {string} { 263 foreach t $string { 264 if {[llength $t] < 2 || [llength $t] > 3} { 265 return -code error -errorcode {TK VALUE FILE_TYPE} \ 266 "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\"" 267 } 268 lappend fileTypes([lindex $t 0]) {*}[lindex $t 1] 269 } 270 271 set types {} 272 foreach t $string { 273 set label [lindex $t 0] 274 set exts {} 275 276 if {[info exists hasDoneType($label)]} { 277 continue 278 } 279 280 # Validate each macType. This is to agree with the 281 # behaviour of TkGetFileFilters(). This list may be 282 # empty. 283 foreach macType [lindex $t 2] { 284 if {[string length $macType] != 4} { 285 return -code error -errorcode {TK VALUE MAC_TYPE} \ 286 "bad Macintosh file type \"$macType\"" 287 } 288 } 289 290 set name "$label \(" 291 set sep "" 292 set doAppend 1 293 foreach ext $fileTypes($label) { 294 if {$ext eq ""} { 295 continue 296 } 297 regsub {^[.]} $ext "*." ext 298 if {![info exists hasGotExt($label,$ext)]} { 299 if {$doAppend} { 300 if {[string length $sep] && [string length $name]>40} { 301 set doAppend 0 302 append name $sep... 303 } else { 304 append name $sep$ext 305 } 306 } 307 lappend exts $ext 308 set hasGotExt($label,$ext) 1 309 } 310 set sep "," 311 } 312 append name "\)" 313 lappend types [list $name $exts] 314 315 set hasDoneType($label) 1 316 } 317 318 return $types 319 }