| 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 2003/02/21 13:32:14 dkf 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 | # |
| 38 | proc 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 | |
| 81 | proc 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 | # |
| 122 | proc ::tk::FocusGroup_Create {t} { |
| 123 | variable ::tk::Priv |
| 124 | if {[string compare [winfo toplevel $t] $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 | # |
| 141 | proc ::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 | # |
| 157 | proc ::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 | # |
| 171 | proc ::tk::FocusGroup_Destroy {t w} { |
| 172 | variable FocusIn |
| 173 | variable FocusOut |
| 174 | variable ::tk::Priv |
| 175 | |
| 176 | if {[string equal $t $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)] && \ |
| 188 | [string equal $Priv(focus,$t) $w]} { |
| 189 | set Priv(focus,$t) "" |
| 190 | } |
| 191 | catch { |
| 192 | unset FocusIn($t,$w) |
| 193 | } |
| 194 | catch { |
| 195 | unset FocusOut($t,$w) |
| 196 | } |
| 197 | } |
| 198 | } |
| 199 | |
| 200 | # ::tk::FocusGroup_In -- |
| 201 | # |
| 202 | # Handles the <FocusIn> event. Calls the FocusIn command for the newly |
| 203 | # focused widget in the focus group. |
| 204 | # |
| 205 | proc ::tk::FocusGroup_In {t w detail} { |
| 206 | variable FocusIn |
| 207 | variable ::tk::Priv |
| 208 | |
| 209 | if {[string compare $detail NotifyNonlinear] && \ |
| 210 | [string compare $detail NotifyNonlinearVirtual]} { |
| 211 | # This is caused by mouse moving out&in of the window *or* |
| 212 | # ordinary keypresses some window managers (ie: CDE [Bug: 2960]). |
| 213 | return |
| 214 | } |
| 215 | if {![info exists FocusIn($t,$w)]} { |
| 216 | set FocusIn($t,$w) "" |
| 217 | return |
| 218 | } |
| 219 | if {![info exists Priv(focus,$t)]} { |
| 220 | return |
| 221 | } |
| 222 | if {[string equal $Priv(focus,$t) $w]} { |
| 223 | # This is already in focus |
| 224 | # |
| 225 | return |
| 226 | } else { |
| 227 | set Priv(focus,$t) $w |
| 228 | eval $FocusIn($t,$w) |
| 229 | } |
| 230 | } |
| 231 | |
| 232 | # ::tk::FocusGroup_Out -- |
| 233 | # |
| 234 | # Handles the <FocusOut> event. Checks if this is really a lose |
| 235 | # focus event, not one generated by the mouse moving out of the |
| 236 | # toplevel window. Calls the FocusOut command for the widget |
| 237 | # who loses its focus. |
| 238 | # |
| 239 | proc ::tk::FocusGroup_Out {t w detail} { |
| 240 | variable FocusOut |
| 241 | variable ::tk::Priv |
| 242 | |
| 243 | if {[string compare $detail NotifyNonlinear] && \ |
| 244 | [string compare $detail NotifyNonlinearVirtual]} { |
| 245 | # This is caused by mouse moving out of the window |
| 246 | return |
| 247 | } |
| 248 | if {![info exists Priv(focus,$t)]} { |
| 249 | return |
| 250 | } |
| 251 | if {![info exists FocusOut($t,$w)]} { |
| 252 | return |
| 253 | } else { |
| 254 | eval $FocusOut($t,$w) |
| 255 | set Priv(focus,$t) "" |
| 256 | } |
| 257 | } |
| 258 | |
| 259 | # ::tk::FDGetFileTypes -- |
| 260 | # |
| 261 | # Process the string given by the -filetypes option of the file |
| 262 | # dialogs. Similar to the C function TkGetFileFilters() on the Mac |
| 263 | # and Windows platform. |
| 264 | # |
| 265 | proc ::tk::FDGetFileTypes {string} { |
| 266 | foreach t $string { |
| 267 | if {[llength $t] < 2 || [llength $t] > 3} { |
| 268 | error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\"" |
| 269 | } |
| 270 | eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1] |
| 271 | } |
| 272 | |
| 273 | set types {} |
| 274 | foreach t $string { |
| 275 | set label [lindex $t 0] |
| 276 | set exts {} |
| 277 | |
| 278 | if {[info exists hasDoneType($label)]} { |
| 279 | continue |
| 280 | } |
| 281 | |
| 282 | set name "$label (" |
| 283 | set sep "" |
| 284 | set doAppend 1 |
| 285 | foreach ext $fileTypes($label) { |
| 286 | if {[string equal $ext ""]} { |
| 287 | continue |
| 288 | } |
| 289 | regsub {^[.]} $ext "*." ext |
| 290 | if {![info exists hasGotExt($label,$ext)]} { |
| 291 | if {$doAppend} { |
| 292 | if {[string length $sep] && [string length $name]>40} { |
| 293 | set doAppend 0 |
| 294 | append name $sep... |
| 295 | } else { |
| 296 | append name $sep$ext |
| 297 | } |
| 298 | } |
| 299 | lappend exts $ext |
| 300 | set hasGotExt($label,$ext) 1 |
| 301 | } |
| 302 | set sep , |
| 303 | } |
| 304 | append name ")" |
| 305 | lappend types [list $name $exts] |
| 306 | |
| 307 | set hasDoneType($label) 1 |
| 308 | } |
| 309 | |
| 310 | return $types |
| 311 | } |