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