1 |
578 |
markom |
# This file is a Tcl script to test out the "winfo" command. It is
|
2 |
|
|
# organized in the standard fashion for Tcl tests.
|
3 |
|
|
#
|
4 |
|
|
# Copyright (c) 1994 The Regents of the University of California.
|
5 |
|
|
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
6 |
|
|
#
|
7 |
|
|
# See the file "license.terms" for information on usage and redistribution
|
8 |
|
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
9 |
|
|
#
|
10 |
|
|
# RCS: @(#) $Id: winfo.test,v 1.1.1.1 2002-01-16 10:26:00 markom Exp $
|
11 |
|
|
|
12 |
|
|
if {[info procs test] != "test"} {
|
13 |
|
|
source defs
|
14 |
|
|
}
|
15 |
|
|
|
16 |
|
|
foreach i [winfo children .] {
|
17 |
|
|
catch {destroy $i}
|
18 |
|
|
}
|
19 |
|
|
wm geometry . {}
|
20 |
|
|
raise .
|
21 |
|
|
|
22 |
|
|
# eatColors --
|
23 |
|
|
# Creates a toplevel window and allocates enough colors in it to
|
24 |
|
|
# use up all the slots in the colormap.
|
25 |
|
|
#
|
26 |
|
|
# Arguments:
|
27 |
|
|
# w - Name of toplevel window to create.
|
28 |
|
|
# options - Options for w, such as "-colormap new".
|
29 |
|
|
|
30 |
|
|
proc eatColors {w {options ""}} {
|
31 |
|
|
catch {destroy $w}
|
32 |
|
|
eval toplevel $w $options
|
33 |
|
|
wm geom $w +0+0
|
34 |
|
|
canvas $w.c -width 400 -height 200 -bd 0
|
35 |
|
|
pack $w.c
|
36 |
|
|
for {set y 0} {$y < 8} {incr y} {
|
37 |
|
|
for {set x 0} {$x < 40} {incr x} {
|
38 |
|
|
set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
|
39 |
|
|
$w.c create rectangle [expr 10*$x] [expr 20*$y] \
|
40 |
|
|
[expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
|
41 |
|
|
-fill $color
|
42 |
|
|
}
|
43 |
|
|
}
|
44 |
|
|
update
|
45 |
|
|
}
|
46 |
|
|
|
47 |
|
|
# XXX - This test file is woefully incomplete. At present, only a
|
48 |
|
|
# few of the winfo options are tested.
|
49 |
|
|
|
50 |
|
|
test winfo-1.1 {"winfo atom" command} {
|
51 |
|
|
list [catch {winfo atom} msg] $msg
|
52 |
|
|
} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
|
53 |
|
|
test winfo-1.2 {"winfo atom" command} {
|
54 |
|
|
list [catch {winfo atom a b} msg] $msg
|
55 |
|
|
} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
|
56 |
|
|
test winfo-1.3 {"winfo atom" command} {
|
57 |
|
|
list [catch {winfo atom a b c d} msg] $msg
|
58 |
|
|
} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
|
59 |
|
|
test winfo-1.4 {"winfo atom" command} {
|
60 |
|
|
list [catch {winfo atom -displayof geek foo} msg] $msg
|
61 |
|
|
} {1 {bad window path name "geek"}}
|
62 |
|
|
test winfo-1.5 {"winfo atom" command} {
|
63 |
|
|
winfo atom PRIMARY
|
64 |
|
|
} 1
|
65 |
|
|
test winfo-1.6 {"winfo atom" command} {
|
66 |
|
|
winfo atom -displayof . PRIMARY
|
67 |
|
|
} 1
|
68 |
|
|
|
69 |
|
|
test winfo-2.1 {"winfo atomname" command} {
|
70 |
|
|
list [catch {winfo atomname} msg] $msg
|
71 |
|
|
} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}}
|
72 |
|
|
test winfo-2.2 {"winfo atomname" command} {
|
73 |
|
|
list [catch {winfo atomname a b} msg] $msg
|
74 |
|
|
} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}}
|
75 |
|
|
test winfo-2.3 {"winfo atomname" command} {
|
76 |
|
|
list [catch {winfo atomname a b c d} msg] $msg
|
77 |
|
|
} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}}
|
78 |
|
|
test winfo-2.4 {"winfo atomname" command} {
|
79 |
|
|
list [catch {winfo atomname -displayof geek foo} msg] $msg
|
80 |
|
|
} {1 {bad window path name "geek"}}
|
81 |
|
|
test winfo-2.5 {"winfo atomname" command} {
|
82 |
|
|
list [catch {winfo atomname 44215} msg] $msg
|
83 |
|
|
} {1 {no atom exists with id "44215"}}
|
84 |
|
|
test winfo-2.6 {"winfo atomname" command} {
|
85 |
|
|
winfo atomname 2
|
86 |
|
|
} SECONDARY
|
87 |
|
|
test winfo-2.7 {"winfo atom" command} {
|
88 |
|
|
winfo atomname -displayof . 2
|
89 |
|
|
} SECONDARY
|
90 |
|
|
|
91 |
|
|
if {([winfo depth .] == 8) && ([winfo visual .] == "pseudocolor")} {
|
92 |
|
|
test winfo-3.1 {"winfo colormapfull" command} {
|
93 |
|
|
list [catch {winfo colormapfull} msg] $msg
|
94 |
|
|
} {1 {wrong # args: should be "winfo colormapfull window"}}
|
95 |
|
|
test winfo-3.2 {"winfo colormapfull" command} {
|
96 |
|
|
list [catch {winfo colormapfull a b} msg] $msg
|
97 |
|
|
} {1 {wrong # args: should be "winfo colormapfull window"}}
|
98 |
|
|
test winfo-3.3 {"winfo colormapfull" command} {
|
99 |
|
|
list [catch {winfo colormapfull foo} msg] $msg
|
100 |
|
|
} {1 {bad window path name "foo"}}
|
101 |
|
|
test winfo-3.4 {"winfo colormapfull" command} {macOrUnix} {
|
102 |
|
|
eatColors .t {-colormap new}
|
103 |
|
|
set result [list [winfo colormapfull .] [winfo colormapfull .t]]
|
104 |
|
|
.t.c delete 34
|
105 |
|
|
lappend result [winfo colormapfull .t]
|
106 |
|
|
.t.c create rectangle 30 30 80 80 -fill #441739
|
107 |
|
|
lappend result [winfo colormapfull .t]
|
108 |
|
|
.t.c create rectangle 40 40 90 90 -fill #ffeedd
|
109 |
|
|
lappend result [winfo colormapfull .t]
|
110 |
|
|
destroy .t.c
|
111 |
|
|
lappend result [winfo colormapfull .t]
|
112 |
|
|
} {0 1 0 0 1 0}
|
113 |
|
|
catch {destroy .t}
|
114 |
|
|
}
|
115 |
|
|
|
116 |
|
|
catch {destroy .t}
|
117 |
|
|
toplevel .t -width 550 -height 400
|
118 |
|
|
frame .t.f -width 80 -height 60 -bd 2 -relief raised
|
119 |
|
|
place .t.f -x 50 -y 50
|
120 |
|
|
wm geom .t +0+0
|
121 |
|
|
update
|
122 |
|
|
test winfo-4.1 {"winfo containing" command} {
|
123 |
|
|
list [catch {winfo containing 22} msg] $msg
|
124 |
|
|
} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}}
|
125 |
|
|
test winfo-4.2 {"winfo containing" command} {
|
126 |
|
|
list [catch {winfo containing a b c} msg] $msg
|
127 |
|
|
} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}}
|
128 |
|
|
test winfo-4.3 {"winfo containing" command} {
|
129 |
|
|
list [catch {winfo containing a b c d e} msg] $msg
|
130 |
|
|
} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}}
|
131 |
|
|
test winfo-4.4 {"winfo containing" command} {
|
132 |
|
|
list [catch {winfo containing -displayof geek 25 30} msg] $msg
|
133 |
|
|
} {1 {bad window path name "geek"}}
|
134 |
|
|
test winfo-4.5 {"winfo containing" command} {
|
135 |
|
|
winfo containing [winfo rootx .t.f] [winfo rooty .t.f]
|
136 |
|
|
} .t.f
|
137 |
|
|
test winfo-4.6 {"winfo containing" command} {nonPortable} {
|
138 |
|
|
winfo containing [expr [winfo rootx .t.f]-1] [expr [winfo rooty .t.f]-1]
|
139 |
|
|
} .t
|
140 |
|
|
test winfo-4.7 {"winfo containing" command} {
|
141 |
|
|
set x [winfo containing -display .t.f [expr [winfo rootx .t]+600] \
|
142 |
|
|
[expr [winfo rooty .t.f]+450]]
|
143 |
|
|
expr {($x == ".") || ($x == "")}
|
144 |
|
|
} {1}
|
145 |
|
|
destroy .t
|
146 |
|
|
|
147 |
|
|
test winfo-5.1 {"winfo interps" command} {
|
148 |
|
|
list [catch {winfo interps a} msg] $msg
|
149 |
|
|
} {1 {wrong # args: should be "winfo interps ?-displayof window?"}}
|
150 |
|
|
test winfo-5.2 {"winfo interps" command} {
|
151 |
|
|
list [catch {winfo interps a b c} msg] $msg
|
152 |
|
|
} {1 {wrong # args: should be "winfo interps ?-displayof window?"}}
|
153 |
|
|
test winfo-5.3 {"winfo interps" command} {
|
154 |
|
|
list [catch {winfo interps -displayof geek} msg] $msg
|
155 |
|
|
} {1 {bad window path name "geek"}}
|
156 |
|
|
test winfo-5.4 {"winfo interps" command} {unixOnly} {
|
157 |
|
|
expr [lsearch -exact [winfo interps] [tk appname]] >= 0
|
158 |
|
|
} {1}
|
159 |
|
|
test winfo-5.5 {"winfo interps" command} {unixOnly} {
|
160 |
|
|
expr [lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0
|
161 |
|
|
} {1}
|
162 |
|
|
|
163 |
|
|
test winfo-6.1 {"winfo exists" command} {
|
164 |
|
|
list [catch {winfo exists} msg] $msg
|
165 |
|
|
} {1 {wrong # args: should be "winfo exists window"}}
|
166 |
|
|
test winfo-6.2 {"winfo exists" command} {
|
167 |
|
|
list [catch {winfo exists a b} msg] $msg
|
168 |
|
|
} {1 {wrong # args: should be "winfo exists window"}}
|
169 |
|
|
test winfo-6.3 {"winfo exists" command} {
|
170 |
|
|
winfo exists gorp
|
171 |
|
|
} {0}
|
172 |
|
|
test winfo-6.4 {"winfo exists" command} {
|
173 |
|
|
winfo exists .
|
174 |
|
|
} {1}
|
175 |
|
|
test winfo-6.5 {"winfo exists" command} {
|
176 |
|
|
button .b -text "Test button"
|
177 |
|
|
set x [winfo exists .b]
|
178 |
|
|
pack .b
|
179 |
|
|
update
|
180 |
|
|
bind .b {lappend x [winfo exists .x]}
|
181 |
|
|
destroy .b
|
182 |
|
|
lappend x [winfo exists .x]
|
183 |
|
|
} {1 0 0}
|
184 |
|
|
|
185 |
|
|
catch {destroy .b}
|
186 |
|
|
button .b -text "Help"
|
187 |
|
|
update
|
188 |
|
|
test winfo-7.1 {"winfo pathname" command} {
|
189 |
|
|
list [catch {winfo pathname} msg] $msg
|
190 |
|
|
} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}}
|
191 |
|
|
test winfo-7.2 {"winfo pathname" command} {
|
192 |
|
|
list [catch {winfo pathname a b} msg] $msg
|
193 |
|
|
} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}}
|
194 |
|
|
test winfo-7.3 {"winfo pathname" command} {
|
195 |
|
|
list [catch {winfo pathname a b c d} msg] $msg
|
196 |
|
|
} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}}
|
197 |
|
|
test winfo-7.4 {"winfo pathname" command} {
|
198 |
|
|
list [catch {winfo pathname -displayof geek 25} msg] $msg
|
199 |
|
|
} {1 {bad window path name "geek"}}
|
200 |
|
|
test winfo-7.5 {"winfo pathname" command} {
|
201 |
|
|
list [catch {winfo pathname xyz} msg] $msg
|
202 |
|
|
} {1 {expected integer but got "xyz"}}
|
203 |
|
|
test winfo-7.6 {"winfo pathname" command} {
|
204 |
|
|
list [catch {winfo pathname 224} msg] $msg
|
205 |
|
|
} {1 {window id "224" doesn't exist in this application}}
|
206 |
|
|
test winfo-7.7 {"winfo pathname" command} {
|
207 |
|
|
winfo pathname -displayof .b [winfo id .]
|
208 |
|
|
} {.}
|
209 |
|
|
|
210 |
|
|
if {[string compare testwrapper [info commands testwrapper]] == 0} {
|
211 |
|
|
puts "This application hasn't been compiled with the testwrapper command,"
|
212 |
|
|
puts "therefore I am skipping all of these tests."
|
213 |
|
|
|
214 |
|
|
test winfo-7.8 {"winfo pathname" command} {unixOnly} {
|
215 |
|
|
winfo pathname [testwrapper .]
|
216 |
|
|
} {}
|
217 |
|
|
}
|
218 |
|
|
|
219 |
|
|
test winfo-8.1 {"winfo pointerx" command} {
|
220 |
|
|
catch [winfo pointerx .b]
|
221 |
|
|
} 1
|
222 |
|
|
test winfo-8.2 {"winfo pointery" command} {
|
223 |
|
|
catch [winfo pointery .b]
|
224 |
|
|
} 1
|
225 |
|
|
test winfo-8.3 {"winfo pointerxy" command} {
|
226 |
|
|
catch [winfo pointerxy .b]
|
227 |
|
|
} 1
|
228 |
|
|
|
229 |
|
|
test winfo-9.1 {"winfo viewable" command} {
|
230 |
|
|
list [catch {winfo viewable} msg] $msg
|
231 |
|
|
} {1 {wrong # args: should be "winfo viewable window"}}
|
232 |
|
|
test winfo-9.2 {"winfo viewable" command} {
|
233 |
|
|
list [catch {winfo viewable foo} msg] $msg
|
234 |
|
|
} {1 {bad window path name "foo"}}
|
235 |
|
|
test winfo-9.3 {"winfo viewable" command} {
|
236 |
|
|
winfo viewable .
|
237 |
|
|
} {1}
|
238 |
|
|
test winfo-9.4 {"winfo viewable" command} {
|
239 |
|
|
wm iconify .
|
240 |
|
|
winfo viewable .
|
241 |
|
|
} {0}
|
242 |
|
|
wm deiconify .
|
243 |
|
|
test winfo-9.5 {"winfo viewable" command} {
|
244 |
|
|
frame .f1 -width 100 -height 100 -relief raised -bd 2
|
245 |
|
|
place .f1 -x 0 -y 0
|
246 |
|
|
frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
|
247 |
|
|
place .f1.f2 -x 0 -y 0
|
248 |
|
|
update
|
249 |
|
|
list [winfo viewable .f1] [winfo viewable .f1.f2]
|
250 |
|
|
} {1 1}
|
251 |
|
|
test winfo-9.6 {"winfo viewable" command} {
|
252 |
|
|
eval destroy [winfo child .]
|
253 |
|
|
frame .f1 -width 100 -height 100 -relief raised -bd 2
|
254 |
|
|
frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
|
255 |
|
|
place .f1.f2 -x 0 -y 0
|
256 |
|
|
update
|
257 |
|
|
list [winfo viewable .f1] [winfo viewable .f1.f2]
|
258 |
|
|
} {0 0}
|
259 |
|
|
test winfo-9.7 {"winfo viewable" command} {
|
260 |
|
|
eval destroy [winfo child .]
|
261 |
|
|
frame .f1 -width 100 -height 100 -relief raised -bd 2
|
262 |
|
|
place .f1 -x 0 -y 0
|
263 |
|
|
frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
|
264 |
|
|
place .f1.f2 -x 0 -y 0
|
265 |
|
|
update
|
266 |
|
|
wm iconify .
|
267 |
|
|
list [winfo viewable .f1] [winfo viewable .f1.f2]
|
268 |
|
|
} {0 0}
|
269 |
|
|
wm deiconify .
|
270 |
|
|
eval destroy [winfo child .]
|
271 |
|
|
|
272 |
|
|
test winfo-10.1 {"winfo visualid" command} {
|
273 |
|
|
list [catch {winfo visualid} msg] $msg
|
274 |
|
|
} {1 {wrong # args: should be "winfo visualid window"}}
|
275 |
|
|
test winfo-10.2 {"winfo visualid" command} {
|
276 |
|
|
list [catch {winfo visualid gorp} msg] $msg
|
277 |
|
|
} {1 {bad window path name "gorp"}}
|
278 |
|
|
test winfo-10.3 {"winfo visualid" command} {
|
279 |
|
|
expr 2+[winfo visualid .]-[winfo visualid .]
|
280 |
|
|
} {2}
|
281 |
|
|
|
282 |
|
|
test winfo-11.1 {"winfo visualid" command} {
|
283 |
|
|
list [catch {winfo visualsavailable} msg] $msg
|
284 |
|
|
} {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}}
|
285 |
|
|
test winfo-11.2 {"winfo visualid" command} {
|
286 |
|
|
list [catch {winfo visualsavailable gorp} msg] $msg
|
287 |
|
|
} {1 {bad window path name "gorp"}}
|
288 |
|
|
test winfo-11.3 {"winfo visualid" command} {
|
289 |
|
|
list [catch {winfo visualsavailable . includeids foo} msg] $msg
|
290 |
|
|
} {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}}
|
291 |
|
|
test winfo-11.4 {"winfo visualid" command} {
|
292 |
|
|
llength [lindex [winfo visualsa .] 0]
|
293 |
|
|
} {2}
|
294 |
|
|
test winfo-11.5 {"winfo visualid" command} {
|
295 |
|
|
llength [lindex [winfo visualsa . includeids] 0]
|
296 |
|
|
} {3}
|
297 |
|
|
test winfo-11.6 {"winfo visualid" command} {
|
298 |
|
|
set x [lindex [lindex [winfo visualsa . includeids] 0] 2]
|
299 |
|
|
expr $x + 2 - $x
|
300 |
|
|
} {2}
|
301 |
|
|
|
302 |
|
|
test winfo-12.1 {GetDisplayOf procedure} {
|
303 |
|
|
list [catch {winfo atom - foo x} msg] $msg
|
304 |
|
|
} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
|
305 |
|
|
test winfo-12.2 {GetDisplayOf procedure} {
|
306 |
|
|
list [catch {winfo atom -d bad_window x} msg] $msg
|
307 |
|
|
} {1 {bad window path name "bad_window"}}
|
308 |
|
|
|
309 |
|
|
# Some embedding tests
|
310 |
|
|
#
|
311 |
|
|
|
312 |
|
|
proc MakeEmbed {} {
|
313 |
|
|
frame .con -container 1
|
314 |
|
|
pack .con -expand yes -fill both
|
315 |
|
|
toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0
|
316 |
|
|
button .emb.b
|
317 |
|
|
pack .emb.b -expand yes -fill both
|
318 |
|
|
update
|
319 |
|
|
}
|
320 |
|
|
test winfo-13.1 {root coordinates of embedded toplevel} {macOrUnix} {
|
321 |
|
|
MakeEmbed
|
322 |
|
|
set z [expr [winfo rootx .emb] == [winfo rootx .con] && \
|
323 |
|
|
[winfo rooty .emb] == [winfo rooty .con]]
|
324 |
|
|
destroy .emb
|
325 |
|
|
destroy .con
|
326 |
|
|
set z
|
327 |
|
|
} {1}
|
328 |
|
|
test winfo-13.2 {destroying embedded toplevel} {macOrUnix} {
|
329 |
|
|
catch {destroy .emb}
|
330 |
|
|
update
|
331 |
|
|
expr [winfo exists .emb.b] || [winfo exists .con]
|
332 |
|
|
} 0
|
333 |
|
|
|
334 |
|
|
foreach i [winfo children .] {
|
335 |
|
|
destroy $i
|
336 |
|
|
}
|
337 |
|
|
|
338 |
|
|
test winfo-13.3 {destroying container window} {macOrUnix} {
|
339 |
|
|
MakeEmbed
|
340 |
|
|
destroy .con
|
341 |
|
|
update
|
342 |
|
|
set z [expr [winfo exists .emb.b] || [winfo exists .emb]]
|
343 |
|
|
catch {destroy .emb}
|
344 |
|
|
catch {destroy .con}
|
345 |
|
|
set z
|
346 |
|
|
} 0
|
347 |
|
|
|
348 |
|
|
foreach i [winfo children .] {
|
349 |
|
|
destroy $i
|
350 |
|
|
}
|
351 |
|
|
|
352 |
|
|
test winfo-13.4 {[winfo containing] with embedded windows} {macOrUnix} {
|
353 |
|
|
MakeEmbed
|
354 |
|
|
button .b
|
355 |
|
|
pack .b -expand yes -fill both
|
356 |
|
|
update
|
357 |
|
|
|
358 |
|
|
set z [string compare \
|
359 |
|
|
[winfo containing [winfo rootx .emb.b] [winfo rooty .emb.b]] .emb.b]
|
360 |
|
|
catch {destroy .con}
|
361 |
|
|
catch {destroy .emb}
|
362 |
|
|
set z
|
363 |
|
|
} 0
|
364 |
|
|
|
365 |
|
|
foreach i [winfo children .] {
|
366 |
|
|
catch {destroy $i}
|
367 |
|
|
}
|