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