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