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