1# This file is a Tcl script to test the procedures in the file
2# tkWindow.c.  It is organized in the standard fashion for Tcl tests.
3#
4# Copyright (c) 1995 Sun Microsystems, Inc.
5# Copyright (c) 1998-1999 by Scriptics Corporation.
6# All rights reserved.
7#
8# RCS: @(#) $Id: window.test,v 1.7.2.1 2004/02/13 01:43:05 hobbs Exp $
9
10package require tcltest 2.1
11namespace import -force tcltest::configure
12namespace import -force tcltest::testsDirectory
13namespace import -force tcltest::interpreter
14namespace import -force tcltest::makeFile
15namespace import -force tcltest::removeFile
16configure -testdir [file join [pwd] [file dirname [info script]]]
17configure -loadfile [file join [testsDirectory] constraints.tcl]
18tcltest::loadTestedCommands
19
20update
21
22# XXX This file is woefully incomplete.  Right now it only tests
23# a few parts of a few procedures in tkWindow.c
24
25test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} {
26    proc bgerror msg {
27	global x errorInfo
28	set x [list $msg $errorInfo]
29    }
30    set x unchanged
31    catch {destroy .t}
32    frame .t -width 100 -height 50
33    place .t -x 10 -y 10
34    bind .t <Destroy> {button .t.b -text hello; pack .t.b}
35    update
36    destroy .t
37    update
38    rename bgerror {}
39    set x
40} {{can't create window: parent has been destroyed} {can't create window: parent has been destroyed
41    while executing
42"button .t.b -text hello"
43    (command bound to event)}}
44
45# Most of the tests below don't produce meaningful results;  they
46# will simply dump core if there are bugs.
47
48test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
49    toplevel .t -width 300 -height 200
50    wm geometry .t +0+0
51    frame .t.f  -width 200 -height 200 -relief raised -bd 2
52    place .t.f -x 0 -y 0
53    frame .t.f.f -width 100 -height 100 -relief raised -bd 2
54    place .t.f.f -relx 1 -rely 1 -anchor se
55    bind .t.f <Destroy> {destroy .t}
56    update
57    destroy .t.f
58} {}
59test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
60    toplevel .t -width 300 -height 200
61    wm geometry .t +0+0
62    frame .t.f  -width 200 -height 200 -relief raised -bd 2
63    place .t.f -x 0 -y 0
64    frame .t.f.f -width 100 -height 100 -relief raised -bd 2
65    place .t.f.f -relx 1 -rely 1 -anchor se
66    bind .t.f.f <Destroy> {destroy .t}
67    update
68    destroy .t.f
69} {}
70test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
71    frame .f -width 80 -height 120 -relief raised -bd 2
72    place .f -relx 0.5 -rely 0.5 -anchor center
73    toplevel .f.t -width 300 -height 200
74    wm geometry .f.t +0+0
75    frame .f.t.f  -width 200 -height 200 -relief raised -bd 2
76    place .f.t.f -x 0 -y 0
77    frame .f.t.f.f -width 100 -height 100 -relief raised -bd 2
78    place .f.t.f.f -relx 1 -rely 1 -anchor se
79    update
80    destroy .f
81} {}
82
83test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} \
84        unixOrWin {
85    set script [makeFile {
86        update
87        bind . <Destroy> exit
88        destroy .
89    } script]
90    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
91    removeFile script
92    list $error $msg
93} {0 {}}
94
95test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} \
96        unixOrWin {
97    set script [makeFile {
98        toplevel .t
99        update
100        bind .t <Destroy> exit
101        destroy .t
102    } script]
103    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
104    removeFile script
105    list $error $msg
106} {0 {}}
107
108test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} \
109        unixOrWin {
110    set script [makeFile {
111        toplevel .t
112        update
113        bind .t <Destroy> exit
114        destroy .
115    } script]
116    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
117    removeFile script
118    list $error $msg
119} {0 {}}
120
121test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} \
122        unixOrWin {
123    set script [makeFile {
124        toplevel .t
125        toplevel .t.f
126        update
127        bind .t.f <Destroy> exit
128        destroy .
129    } script]
130    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
131    removeFile script
132    list $error $msg
133} {0 {}}
134
135test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \
136        unixOrWin {
137    set script [makeFile {
138        toplevel .t1
139        toplevel .t2
140        toplevel .t3
141        update
142        bind .t3 <Destroy> {destroy .t2}
143        bind .t2 <Destroy> {destroy .t1}
144        bind .t1 <Destroy> {exit 0}
145        destroy .t3
146    } script]
147    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
148    removeFile script
149    list $error $msg
150} {0 {}}
151
152test window-2.9 {Tk_DestroyWindow, Destroy bindings evaluated after exit} \
153    unixOrWin {
154    set script [makeFile {
155        toplevel .t1
156        toplevel .t2
157        update
158        bind .t2 <Destroy> {puts "Destroy .t2" ; exit 1}
159        bind .t1 <Destroy> {puts "Destroy .t1" ; exit 0}
160        destroy .t2
161    } script]
162    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
163    removeFile script
164    list $error $msg
165} {0 {Destroy .t2
166Destroy .t1}}
167
168test window-2.10 {Tk_DestroyWindow, Destroy binding evaluated once} unixOrWin {
169    set script [makeFile {
170        update
171        bind . <Destroy> {
172            puts "Destroy ."
173            bind . <Destroy> {puts "Re-Destroy ."}
174            exit 0
175        }
176        destroy .
177    } script]
178    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
179    removeFile script
180    list $error $msg
181} {0 {Destroy .}}
182
183test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \
184        unixOrWin {
185    set script [makeFile {
186        toplevel .t1
187        toplevel .t2
188        update
189        bind .t1 <Destroy> {
190            if {[catch {entry .t2.newchild}]} {
191                puts YES
192            } else {
193                puts NO
194            }
195        }
196        bind .t2 <Destroy> {exit}
197        destroy .t2
198    } script]
199    set error [catch {exec [interpreter] $script -geometry 10x10+0+0} msg]
200    removeFile script
201    list $error $msg
202} {0 YES}
203
204# Some tests require the testmenubar command
205testConstraint testmenubar [llength [info commands testmenubar]]
206
207test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \
208	{unixOnly testmenubar} {
209    catch {destroy .t}
210    toplevel .t -width 300 -height 200
211    wm geometry .t +0+0
212    pack [entry .t.e]
213    frame .t.f -bd 2 -relief raised
214    testmenubar window .t .t.f
215    update
216    # If stacking order isn't handle properly, generates an X error.
217} {}
218test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} \
219	{unixOnly testmenubar} {
220    catch {destroy .t}
221    toplevel .t -width 300 -height 200
222    wm geometry .t +0+0
223    pack [entry .t.e]
224    pack [entry .t.e2]
225    update
226    frame .t.f -bd 2 -relief raised
227    raise .t.f .t.e
228    testmenubar window .t .t.f
229    update
230    # If stacking order isn't handled properly, generates an X error.
231} {}
232
233test window-4.1 {Tk_NameToWindow procedure} {testmenubar} {
234    catch {destroy .t}
235    list [catch {winfo geometry .t} msg] $msg
236} {1 {bad window path name ".t"}}
237test window-4.2 {Tk_NameToWindow procedure} {testmenubar} {
238    catch {destroy .t}
239    frame .t -width 100 -height 50
240    place .t -x 10 -y 10
241    update
242    list [catch {winfo geometry .t} msg] $msg
243} {0 100x50+10+10}
244
245test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \
246	{unixOnly testmenubar} {
247    catch {destroy .t}
248    toplevel .t -width 300 -height 200
249    wm geometry .t +0+0
250    pack [entry .t.e]
251    pack [entry .t.e2]
252    frame .t.f -bd 2 -relief raised
253    testmenubar window .t .t.f
254    update
255    lower .t.e2 .t.f
256    update
257    # If stacking order isn't handled properly, generates an X error.
258} {}
259
260# cleanup
261::tcltest::cleanupTests
262return
263
264
265
266
267
268
269
270
271
272
273
274
275