[37] | 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 | } |
---|