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