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 | } |
---|