Commit | Line | Data |
---|---|---|
920dae64 AT |
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 | } |