3 # Some functions needed for the common dialog boxes. Probably need to go
6 # Copyright (c) 1996 Sun Microsystems, Inc.
8 # See the file "license.terms" for information on usage and redistribution
9 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 # tclParseConfigSpec --
14 # Parses a list of "-option value" pairs. If all options and
15 # values are legal, the values are stored in
16 # $data($option). Otherwise an error message is returned. When
17 # an error happens, the data() array may have been partially
18 # modified, but all the modified members of the data(0 array are
19 # guaranteed to have valid values. This is different than
20 # Tk_ConfigureWidget() which does not modify the value of a
21 # widget record if any error occurs.
25 # w = widget record to modify. Must be the pathname of a widget.
28 # {-commandlineswitch resourceName ResourceClass defaultValue verifier}
32 # flags = currently unused.
34 # argList = The list of "-option value" pairs.
36 proc tclParseConfigSpec
{w specs flags argList
} {
39 # 1: Put the specs in associative arrays for faster access
42 if {[llength $spec] < 4} {
43 error "\"spec\" should contain 5 or 4 elements"
45 set cmdsw
[lindex $spec 0]
47 set rname
($cmdsw) [lindex $spec 1]
48 set rclass
($cmdsw) [lindex $spec 2]
49 set def
($cmdsw) [lindex $spec 3]
50 set verproc
($cmdsw) [lindex $spec 4]
53 if {[llength $argList] & 1} {
54 set cmdsw
[lindex $argList end
]
55 if {![info exists cmd
($cmdsw)]} {
56 error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
58 error "value for \"$cmdsw\" missing"
61 # 2: set the default values
63 foreach cmdsw
[array names cmd
] {
64 set data
($cmdsw) $def($cmdsw)
67 # 3: parse the argument list
69 foreach {cmdsw value
} $argList {
70 if {![info exists cmd
($cmdsw)]} {
71 error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
73 set data
($cmdsw) $value
79 proc tclListValidFlags
{v
} {
82 set len
[llength [array names cmd
]]
86 foreach cmdsw
[lsort [array names cmd
]] {
87 append errormsg
"$separator$cmdsw"
98 #----------------------------------------------------------------------
102 # Focus groups are used to handle the user's focusing actions inside a
105 # One example of using focus groups is: when the user focuses on an
106 # entry, the text in the entry is highlighted and the cursor is put to
107 # the end of the text. When the user changes focus to another widget,
108 # the text in the previously focused entry is validated.
110 #----------------------------------------------------------------------
113 # ::tk::FocusGroup_Create --
115 # Create a focus group. All the widgets in a focus group must be
116 # within the same focus toplevel. Each toplevel can have only
117 # one focus group, which is identified by the name of the
120 proc ::tk::FocusGroup_Create {t
} {
122 if {[winfo toplevel $t] ne
$t} {
123 error "$t is not a toplevel window"
125 if {![info exists Priv
(fg
,$t)]} {
127 set Priv
(focus,$t) ""
128 bind $t <FocusIn
> [list tk::FocusGroup_In $t %W
%d
]
129 bind $t <FocusOut
> [list tk::FocusGroup_Out $t %W
%d
]
130 bind $t <Destroy
> [list tk::FocusGroup_Destroy $t %W
]
134 # ::tk::FocusGroup_BindIn --
136 # Add a widget into the "FocusIn" list of the focus group. The $cmd will be
137 # called when the widget is focused on by the user.
139 proc ::tk::FocusGroup_BindIn {t w cmd
} {
142 if {![info exists Priv
(fg
,$t)]} {
143 error "focus group \"$t\" doesn't exist"
145 set FocusIn
($t,$w) $cmd
149 # ::tk::FocusGroup_BindOut --
151 # Add a widget into the "FocusOut" list of the focus group. The
152 # $cmd will be called when the widget loses the focus (User
153 # types Tab or click on another widget).
155 proc ::tk::FocusGroup_BindOut {t w cmd
} {
158 if {![info exists Priv
(fg
,$t)]} {
159 error "focus group \"$t\" doesn't exist"
161 set FocusOut
($t,$w) $cmd
164 # ::tk::FocusGroup_Destroy --
166 # Cleans up when members of the focus group is deleted, or when the
167 # toplevel itself gets deleted.
169 proc ::tk::FocusGroup_Destroy {t w
} {
178 foreach name
[array names FocusIn
$t,*] {
181 foreach name
[array names FocusOut
$t,*] {
182 unset FocusOut
($name)
185 if {[info exists Priv
(focus,$t)] && ($Priv(focus,$t) eq
$w)} {
186 set Priv
(focus,$t) ""
188 unset -nocomplain FocusIn
($t,$w) FocusOut
($t,$w)
192 # ::tk::FocusGroup_In --
194 # Handles the <FocusIn> event. Calls the FocusIn command for the newly
195 # focused widget in the focus group.
197 proc ::tk::FocusGroup_In {t w detail
} {
201 if {$detail ne
"NotifyNonlinear" && $detail ne
"NotifyNonlinearVirtual"} {
202 # This is caused by mouse moving out&in of the window *or*
203 # ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
206 if {![info exists FocusIn
($t,$w)]} {
207 set FocusIn
($t,$w) ""
210 if {![info exists Priv
(focus,$t)]} {
213 if {$Priv(focus,$t) eq
$w} {
214 # This is already in focus
218 set Priv
(focus,$t) $w
223 # ::tk::FocusGroup_Out --
225 # Handles the <FocusOut> event. Checks if this is really a lose
226 # focus event, not one generated by the mouse moving out of the
227 # toplevel window. Calls the FocusOut command for the widget
228 # who loses its focus.
230 proc ::tk::FocusGroup_Out {t w detail
} {
234 if {$detail ne
"NotifyNonlinear" && $detail ne
"NotifyNonlinearVirtual"} {
235 # This is caused by mouse moving out of the window
238 if {![info exists Priv
(focus,$t)]} {
241 if {![info exists FocusOut
($t,$w)]} {
244 eval $FocusOut($t,$w)
245 set Priv
(focus,$t) ""
249 # ::tk::FDGetFileTypes --
251 # Process the string given by the -filetypes option of the file
252 # dialogs. Similar to the C function TkGetFileFilters() on the Mac
253 # and Windows platform.
255 proc ::tk::FDGetFileTypes {string} {
257 if {[llength $t] < 2 ||
[llength $t] > 3} {
258 error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
260 lappend fileTypes
([lindex $t 0]) {*}[lindex $t 1]
265 set label [lindex $t 0]
268 if {[info exists hasDoneType
($label)]} {
272 # Validate each macType. This is to agree with the
273 # behaviour of TkGetFileFilters(). This list may be
275 foreach macType
[lindex $t 2] {
276 if {[string length
$macType] != 4} {
277 error "bad Macintosh file type \"$macType\""
284 foreach ext
$fileTypes($label) {
288 regsub {^
[.
]} $ext "*." ext
289 if {![info exists hasGotExt
($label,$ext)]} {
291 if {[string length
$sep] && [string length
$name]>40} {
299 set hasGotExt
($label,$ext) 1
304 lappend types
[list $name $exts]
306 set hasDoneType
($label) 1