1 # This file is a Tcl script to test out the "winfo" command. It is
2 # organized in the standard fashion for Tcl tests.
4 # Copyright (c) 1994 The Regents of the University of California.
5 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
6 # Copyright (c) 1998-1999 by Scriptics Corporation.
11 if {[lsearch [namespace children] ::tcltest] == -1} {
12 source [file join [pwd] [file dirname [info script]] defs.tcl]
15 foreach i [winfo children .] {
21 # Some tests require the testwrapper command
22 set ::tcltest::testConfig(testwrapper) \
23 [expr {[info commands testwrapper] != {}}]
26 # Creates a toplevel window and allocates enough colors in it to
27 # use up all the slots in the colormap.
30 # w - Name of toplevel window to create.
31 # options - Options for w, such as "-colormap new".
33 proc eatColors {w {options ""}} {
35 eval toplevel $w $options
37 canvas $w.c -width 400 -height 200 -bd 0
39 for {set y 0} {$y < 8} {incr y} {
40 for {set x 0} {$x < 40} {incr x} {
41 set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
42 $w.c create rectangle [expr 10*$x] [expr 20*$y] \
43 [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
50 # XXX - This test file is woefully incomplete. At present, only a
51 # few of the winfo options are tested.
53 test winfo-1.1 {"winfo atom" command} {
54 list [catch {winfo atom} msg] $msg
55 } {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
56 test winfo-1.2 {"winfo atom" command} {
57 list [catch {winfo atom a b} msg] $msg
58 } {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
59 test winfo-1.3 {"winfo atom" command} {
60 list [catch {winfo atom a b c d} msg] $msg
61 } {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
62 test winfo-1.4 {"winfo atom" command} {
63 list [catch {winfo atom -displayof geek foo} msg] $msg
64 } {1 {bad window path name "geek"}}
65 test winfo-1.5 {"winfo atom" command} {
68 test winfo-1.6 {"winfo atom" command} {
69 winfo atom -displayof . PRIMARY
72 test winfo-2.1 {"winfo atomname" command} {
73 list [catch {winfo atomname} msg] $msg
74 } {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}}
75 test winfo-2.2 {"winfo atomname" command} {
76 list [catch {winfo atomname a b} msg] $msg
77 } {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}}
78 test winfo-2.3 {"winfo atomname" command} {
79 list [catch {winfo atomname a b c d} msg] $msg
80 } {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}}
81 test winfo-2.4 {"winfo atomname" command} {
82 list [catch {winfo atomname -displayof geek foo} msg] $msg
83 } {1 {bad window path name "geek"}}
84 test winfo-2.5 {"winfo atomname" command} {
85 list [catch {winfo atomname 44215} msg] $msg
86 } {1 {no atom exists with id "44215"}}
87 test winfo-2.6 {"winfo atomname" command} {
90 test winfo-2.7 {"winfo atom" command} {
91 winfo atomname -displayof . 2
94 # Some tests require the "pseudocolor" visual class.
95 set ::tcltest::testConfig(pseudocolor) \
96 [expr {([winfo depth .] == 8) && ([winfo visual .] == "pseudocolor")}]
98 test winfo-3.1 {"winfo colormapfull" command} {pseudocolor} {
99 list [catch {winfo colormapfull} msg] $msg
100 } {1 {wrong # args: should be "winfo colormapfull window"}}
101 test winfo-3.2 {"winfo colormapfull" command} {pseudocolor} {
102 list [catch {winfo colormapfull a b} msg] $msg
103 } {1 {wrong # args: should be "winfo colormapfull window"}}
104 test winfo-3.3 {"winfo colormapfull" command} {pseudocolor} {
105 list [catch {winfo colormapfull foo} msg] $msg
106 } {1 {bad window path name "foo"}}
107 test winfo-3.4 {"winfo colormapfull" command} {macOrUnix pseudocolor} {
108 eatColors .t {-colormap new}
109 set result [list [winfo colormapfull .] [winfo colormapfull .t]]
111 lappend result [winfo colormapfull .t]
112 .t.c create rectangle 30 30 80 80 -fill #441739
113 lappend result [winfo colormapfull .t]
114 .t.c create rectangle 40 40 90 90 -fill #ffeedd
115 lappend result [winfo colormapfull .t]
117 lappend result [winfo colormapfull .t]
121 toplevel .t -width 550 -height 400
122 frame .t.f -width 80 -height 60 -bd 2 -relief raised
123 place .t.f -x 50 -y 50
126 test winfo-4.1 {"winfo containing" command} {
127 list [catch {winfo containing 22} msg] $msg
128 } {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}}
129 test winfo-4.2 {"winfo containing" command} {
130 list [catch {winfo containing a b c} msg] $msg
131 } {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}}
132 test winfo-4.3 {"winfo containing" command} {
133 list [catch {winfo containing a b c d e} msg] $msg
134 } {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}}
135 test winfo-4.4 {"winfo containing" command} {
136 list [catch {winfo containing -displayof geek 25 30} msg] $msg
137 } {1 {bad window path name "geek"}}
138 test winfo-4.5 {"winfo containing" command} {
139 winfo containing [winfo rootx .t.f] [winfo rooty .t.f]
141 test winfo-4.6 {"winfo containing" command} {nonPortable} {
142 winfo containing [expr [winfo rootx .t.f]-1] [expr [winfo rooty .t.f]-1]
144 test winfo-4.7 {"winfo containing" command} {
145 set x [winfo containing -display .t.f [expr [winfo rootx .t]+600] \
146 [expr [winfo rooty .t.f]+450]]
147 expr {($x == ".") || ($x == "")}
151 test winfo-5.1 {"winfo interps" command} {
152 list [catch {winfo interps a} msg] $msg
153 } {1 {wrong # args: should be "winfo interps ?-displayof window?"}}
154 test winfo-5.2 {"winfo interps" command} {
155 list [catch {winfo interps a b c} msg] $msg
156 } {1 {wrong # args: should be "winfo interps ?-displayof window?"}}
157 test winfo-5.3 {"winfo interps" command} {
158 list [catch {winfo interps -displayof geek} msg] $msg
159 } {1 {bad window path name "geek"}}
160 test winfo-5.4 {"winfo interps" command} {unixOnly} {
161 expr [lsearch -exact [winfo interps] [tk appname]] >= 0
163 test winfo-5.5 {"winfo interps" command} {unixOnly} {
164 expr [lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0
167 test winfo-6.1 {"winfo exists" command} {
168 list [catch {winfo exists} msg] $msg
169 } {1 {wrong # args: should be "winfo exists window"}}
170 test winfo-6.2 {"winfo exists" command} {
171 list [catch {winfo exists a b} msg] $msg
172 } {1 {wrong # args: should be "winfo exists window"}}
173 test winfo-6.3 {"winfo exists" command} {
176 test winfo-6.4 {"winfo exists" command} {
179 test winfo-6.5 {"winfo exists" command} {
180 button .b -text "Test button"
181 set x [winfo exists .b]
184 bind .b <Destroy> {lappend x [winfo exists .x]}
186 lappend x [winfo exists .x]
190 button .b -text "Help"
192 test winfo-7.1 {"winfo pathname" command} {
193 list [catch {winfo pathname} msg] $msg
194 } {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}}
195 test winfo-7.2 {"winfo pathname" command} {
196 list [catch {winfo pathname a b} msg] $msg
197 } {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}}
198 test winfo-7.3 {"winfo pathname" command} {
199 list [catch {winfo pathname a b c d} msg] $msg
200 } {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}}
201 test winfo-7.4 {"winfo pathname" command} {
202 list [catch {winfo pathname -displayof geek 25} msg] $msg
203 } {1 {bad window path name "geek"}}
204 test winfo-7.5 {"winfo pathname" command} {
205 list [catch {winfo pathname xyz} msg] $msg
206 } {1 {expected integer but got "xyz"}}
207 test winfo-7.6 {"winfo pathname" command} {
208 list [catch {winfo pathname 224} msg] $msg
209 } {1 {window id "224" doesn't exist in this application}}
210 test winfo-7.7 {"winfo pathname" command} {
211 winfo pathname -displayof .b [winfo id .]
213 test winfo-7.8 {"winfo pathname" command} {unixOnly testwrapper} {
214 winfo pathname [testwrapper .]
217 test winfo-8.1 {"winfo pointerx" command} {
218 catch [winfo pointerx .b]
220 test winfo-8.2 {"winfo pointery" command} {
221 catch [winfo pointery .b]
223 test winfo-8.3 {"winfo pointerxy" command} {
224 catch [winfo pointerxy .b]
227 test winfo-9.1 {"winfo viewable" command} {
228 list [catch {winfo viewable} msg] $msg
229 } {1 {wrong # args: should be "winfo viewable window"}}
230 test winfo-9.2 {"winfo viewable" command} {
231 list [catch {winfo viewable foo} msg] $msg
232 } {1 {bad window path name "foo"}}
233 test winfo-9.3 {"winfo viewable" command} {
236 test winfo-9.4 {"winfo viewable" command} {
241 test winfo-9.5 {"winfo viewable" command} {
242 frame .f1 -width 100 -height 100 -relief raised -bd 2
244 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
245 place .f1.f2 -x 0 -y 0
247 list [winfo viewable .f1] [winfo viewable .f1.f2]
249 test winfo-9.6 {"winfo viewable" command} {
250 eval destroy [winfo child .]
251 frame .f1 -width 100 -height 100 -relief raised -bd 2
252 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
253 place .f1.f2 -x 0 -y 0
255 list [winfo viewable .f1] [winfo viewable .f1.f2]
257 test winfo-9.7 {"winfo viewable" command} {
258 eval destroy [winfo child .]
259 frame .f1 -width 100 -height 100 -relief raised -bd 2
261 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
262 place .f1.f2 -x 0 -y 0
265 list [winfo viewable .f1] [winfo viewable .f1.f2]
268 eval destroy [winfo child .]
270 test winfo-10.1 {"winfo visualid" command} {
271 list [catch {winfo visualid} msg] $msg
272 } {1 {wrong # args: should be "winfo visualid window"}}
273 test winfo-10.2 {"winfo visualid" command} {
274 list [catch {winfo visualid gorp} msg] $msg
275 } {1 {bad window path name "gorp"}}
276 test winfo-10.3 {"winfo visualid" command} {
277 expr 2+[winfo visualid .]-[winfo visualid .]
280 test winfo-11.1 {"winfo visualid" command} {
281 list [catch {winfo visualsavailable} msg] $msg
282 } {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}}
283 test winfo-11.2 {"winfo visualid" command} {
284 list [catch {winfo visualsavailable gorp} msg] $msg
285 } {1 {bad window path name "gorp"}}
286 test winfo-11.3 {"winfo visualid" command} {
287 list [catch {winfo visualsavailable . includeids foo} msg] $msg
288 } {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}}
289 test winfo-11.4 {"winfo visualid" command} {
290 llength [lindex [winfo visualsa .] 0]
292 test winfo-11.5 {"winfo visualid" command} {
293 llength [lindex [winfo visualsa . includeids] 0]
295 test winfo-11.6 {"winfo visualid" command} {
296 set x [lindex [lindex [winfo visualsa . includeids] 0] 2]
300 test winfo-12.1 {GetDisplayOf procedure} {
301 list [catch {winfo atom - foo x} msg] $msg
302 } {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
303 test winfo-12.2 {GetDisplayOf procedure} {
304 list [catch {winfo atom -d bad_window x} msg] $msg
305 } {1 {bad window path name "bad_window"}}
307 # Some embedding tests
311 frame .con -container 1
312 pack .con -expand yes -fill both
313 toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0
315 pack .emb.b -expand yes -fill both
318 test winfo-13.1 {root coordinates of embedded toplevel} {
320 set z [expr [winfo rootx .emb] == [winfo rootx .con] && \
321 [winfo rooty .emb] == [winfo rooty .con]]
326 test winfo-13.2 {destroying embedded toplevel} {
329 expr [winfo exists .emb.b] || [winfo exists .con]
332 foreach i [winfo children .] {
336 test winfo-13.3 {destroying container window} {
340 set z [expr [winfo exists .emb.b] || [winfo exists .emb]]
346 foreach i [winfo children .] {
350 test winfo-13.4 {[winfo containing] with embedded windows} {
353 pack .b -expand yes -fill both
356 set z [string compare \
357 [winfo containing [winfo rootx .emb.b] [winfo rooty .emb.b]] .emb.b]
363 foreach i [winfo children .] {
368 ::tcltest::cleanupTests