summaryrefslogtreecommitdiffstats
path: root/library/comdlg.tcl
blob: 51154bbf52ecff5dfb667c530aef7404c8c2c5a4 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
# comdlg.tcl --
#
#	Some functions needed for the common dialog boxes. Probably need to go
#	in a different file.
#
# RCS: @(#) $Id: comdlg.tcl,v 1.9.2.1 2006/01/25 18:21:41 dgp Exp $
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

# tclParseConfigSpec --
#
#	Parses a list of "-option value" pairs. If all options and
#	values are legal, the values are stored in
#	$data($option). Otherwise an error message is returned. When
#	an error happens, the data() array may have been partially
#	modified, but all the modified members of the data(0 array are
#	guaranteed to have valid values. This is different than
#	Tk_ConfigureWidget() which does not modify the value of a
#	widget record if any error occurs.
#
# Arguments:
#
# w = widget record to modify. Must be the pathname of a widget.
#
# specs = {
#    {-commandlineswitch resourceName ResourceClass defaultValue verifier}
#    {....}
# }
#
# flags = currently unused.
#
# argList = The list of  "-option value" pairs.
#
proc tclParseConfigSpec {w specs flags argList} {
    upvar #0 $w data

    # 1: Put the specs in associative arrays for faster access
    #
    foreach spec $specs {
	if {[llength $spec] < 4} {
	    error "\"spec\" should contain 5 or 4 elements"
	}
	set cmdsw [lindex $spec 0]
	set cmd($cmdsw) ""
	set rname($cmdsw)   [lindex $spec 1]
	set rclass($cmdsw)  [lindex $spec 2]
	set def($cmdsw)     [lindex $spec 3]
	set verproc($cmdsw) [lindex $spec 4]
    }

    if {[llength $argList] & 1} {
	set cmdsw [lindex $argList end]
	if {![info exists cmd($cmdsw)]} {
	    error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
	}
	error "value for \"$cmdsw\" missing"
    }

    # 2: set the default values
    #
    foreach cmdsw [array names cmd] {
	set data($cmdsw) $def($cmdsw)
    }

    # 3: parse the argument list
    #
    foreach {cmdsw value} $argList {
	if {![info exists cmd($cmdsw)]} {
	    error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
	}
	set data($cmdsw) $value
    }

    # Done!
}

proc tclListValidFlags {v} {
    upvar $v cmd

    set len [llength [array names cmd]]
    set i 1
    set separator ""
    set errormsg ""
    foreach cmdsw [lsort [array names cmd]] {
	append errormsg "$separator$cmdsw"
	incr i
	if {$i == $len} {
	    set separator ", or "
	} else {
	    set separator ", "
	}
    }
    return $errormsg
}

#----------------------------------------------------------------------
#
#			Focus Group
#
# Focus groups are used to handle the user's focusing actions inside a
# toplevel.
#
# One example of using focus groups is: when the user focuses on an
# entry, the text in the entry is highlighted and the cursor is put to
# the end of the text. When the user changes focus to another widget,
# the text in the previously focused entry is validated.
#
#----------------------------------------------------------------------


# ::tk::FocusGroup_Create --
#
#	Create a focus group. All the widgets in a focus group must be
#	within the same focus toplevel. Each toplevel can have only
#	one focus group, which is identified by the name of the
#	toplevel widget.
#
proc ::tk::FocusGroup_Create {t} {
    variable ::tk::Priv
    if {[winfo toplevel $t] ne $t} {
	error "$t is not a toplevel window"
    }
    if {![info exists Priv(fg,$t)]} {
	set Priv(fg,$t) 1
	set Priv(focus,$t) ""
	bind $t <FocusIn>  [list tk::FocusGroup_In  $t %W %d]
	bind $t <FocusOut> [list tk::FocusGroup_Out $t %W %d]
	bind $t <Destroy>  [list tk::FocusGroup_Destroy $t %W]
    }
}

# ::tk::FocusGroup_BindIn --
#
# Add a widget into the "FocusIn" list of the focus group. The $cmd will be
# called when the widget is focused on by the user.
#
proc ::tk::FocusGroup_BindIn {t w cmd} {
    variable FocusIn
    variable ::tk::Priv
    if {![info exists Priv(fg,$t)]} {
	error "focus group \"$t\" doesn't exist"
    }
    set FocusIn($t,$w) $cmd
}


# ::tk::FocusGroup_BindOut --
#
#	Add a widget into the "FocusOut" list of the focus group. The
#	$cmd will be called when the widget loses the focus (User
#	types Tab or click on another widget).
#
proc ::tk::FocusGroup_BindOut {t w cmd} {
    variable FocusOut
    variable ::tk::Priv
    if {![info exists Priv(fg,$t)]} {
	error "focus group \"$t\" doesn't exist"
    }
    set FocusOut($t,$w) $cmd
}

# ::tk::FocusGroup_Destroy --
#
#	Cleans up when members of the focus group is deleted, or when the
#	toplevel itself gets deleted.
#
proc ::tk::FocusGroup_Destroy {t w} {
    variable FocusIn
    variable FocusOut
    variable ::tk::Priv

    if {$t eq $w} {
	unset Priv(fg,$t)
	unset Priv(focus,$t) 

	foreach name [array names FocusIn $t,*] {
	    unset FocusIn($name)
	}
	foreach name [array names FocusOut $t,*] {
	    unset FocusOut($name)
	}
    } else {
	if {[info exists Priv(focus,$t)] && $Priv(focus,$t) eq $w} {
	    set Priv(focus,$t) ""
	}
	unset -nocomplain FocusIn($t,$w) FocusOut($t,$w)
    }
}

# ::tk::FocusGroup_In --
#
#	Handles the <FocusIn> event. Calls the FocusIn command for the newly
#	focused widget in the focus group.
#
proc ::tk::FocusGroup_In {t w detail} {
    variable FocusIn
    variable ::tk::Priv

    if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
	# This is caused by mouse moving out&in of the window *or*
	# ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
	return
    }
    if {![info exists FocusIn($t,$w)]} {
	set FocusIn($t,$w) ""
	return
    }
    if {![info exists Priv(focus,$t)]} {
	return
    }
    if {$Priv(focus,$t) eq $w} {
	# This is already in focus
	#
	return
    } else {
	set Priv(focus,$t) $w
	eval $FocusIn($t,$w)
    }
}

# ::tk::FocusGroup_Out --
#
#	Handles the <FocusOut> event. Checks if this is really a lose
#	focus event, not one generated by the mouse moving out of the
#	toplevel window.  Calls the FocusOut command for the widget
#	who loses its focus.
#
proc ::tk::FocusGroup_Out {t w detail} {
    variable FocusOut
    variable ::tk::Priv

    if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
	# This is caused by mouse moving out of the window
	return
    }
    if {![info exists Priv(focus,$t)]} {
	return
    }
    if {![info exists FocusOut($t,$w)]} {
	return
    } else {
	eval $FocusOut($t,$w)
	set Priv(focus,$t) ""
    }
}

# ::tk::FDGetFileTypes --
#
#	Process the string given by the -filetypes option of the file
#	dialogs. Similar to the C function TkGetFileFilters() on the Mac
#	and Windows platform.
#
proc ::tk::FDGetFileTypes {string} {
    foreach t $string {
	if {[llength $t] < 2 || [llength $t] > 3} {
	    error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
	}
	eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1]
    }

    set types {}
    foreach t $string {
	set label [lindex $t 0]
	set exts {}

	if {[info exists hasDoneType($label)]} {
	    continue
	}

	set name "$label \("
	set sep ""
	set doAppend 1
	foreach ext $fileTypes($label) {
	    if {$ext eq ""} {
		continue
	    }
	    regsub {^[.]} $ext "*." ext
	    if {![info exists hasGotExt($label,$ext)]} {
		if {$doAppend} {
		    if {[string length $sep] && [string length $name]>40} {
			set doAppend 0
			append name $sep...
		    } else {
			append name $sep$ext
		    }
		}
		lappend exts $ext
		set hasGotExt($label,$ext) 1
	    }
	    set sep ","
	}
	append name "\)"
	lappend types [list $name $exts]

	set hasDoneType($label) 1
    }

    return $types
}