94 lines
2.8 KiB
Plaintext
94 lines
2.8 KiB
Plaintext
# This file is a Tcl script to test the procedures in the file
|
|
# tkWindow.c. It is organized in the standard fashion for Tcl tests.
|
|
#
|
|
# Copyright (c) 1995 Sun Microsystems, Inc.
|
|
#
|
|
# See the file "license.terms" for information on usage and redistribution
|
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
#
|
|
# SCCS: @(#) window.test 1.5 96/08/21 10:10:24
|
|
|
|
if {[info procs test] != "test"} {
|
|
source defs
|
|
}
|
|
|
|
foreach i [winfo children .] {
|
|
destroy $i
|
|
}
|
|
wm geometry . {}
|
|
raise .
|
|
update
|
|
|
|
# XXX This file is woefully incomplete. Right now it only tests
|
|
# a few parts of a few procedures in tkWindow.c
|
|
|
|
test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} {
|
|
proc bgerror msg {
|
|
global x errorInfo
|
|
set x [list $msg $errorInfo]
|
|
}
|
|
set x unchanged
|
|
catch {destroy .t}
|
|
frame .t -width 100 -height 50
|
|
place .t -x 10 -y 10
|
|
bind .t <Destroy> {button .t.b -text hello; pack .t.b}
|
|
update
|
|
destroy .t
|
|
update
|
|
rename bgerror {}
|
|
set x
|
|
} {{can't create window: parent has been destroyed} {can't create window: parent has been destroyed
|
|
while executing
|
|
"button .t.b -text hello"
|
|
(command bound to event)}}
|
|
|
|
# Most of the tests below don't produce meaningful results; they
|
|
# will simply dump core if there are bugs.
|
|
|
|
test window-1.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
|
|
toplevel .t -width 300 -height 200
|
|
wm geometry .t +0+0
|
|
frame .t.f -width 200 -height 200 -relief raised -bd 2
|
|
place .t.f -x 0 -y 0
|
|
frame .t.f.f -width 100 -height 100 -relief raised -bd 2
|
|
place .t.f.f -relx 1 -rely 1 -anchor se
|
|
bind .t.f <Destroy> {destroy .t}
|
|
update
|
|
destroy .t.f
|
|
} {}
|
|
test window-1.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
|
|
toplevel .t -width 300 -height 200
|
|
wm geometry .t +0+0
|
|
frame .t.f -width 200 -height 200 -relief raised -bd 2
|
|
place .t.f -x 0 -y 0
|
|
frame .t.f.f -width 100 -height 100 -relief raised -bd 2
|
|
place .t.f.f -relx 1 -rely 1 -anchor se
|
|
bind .t.f.f <Destroy> {destroy .t}
|
|
update
|
|
destroy .t.f
|
|
} {}
|
|
test window-1.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} {
|
|
frame .f -width 80 -height 120 -relief raised -bd 2
|
|
place .f -relx 0.5 -rely 0.5 -anchor center
|
|
toplevel .f.t -width 300 -height 200
|
|
wm geometry .f.t +0+0
|
|
frame .f.t.f -width 200 -height 200 -relief raised -bd 2
|
|
place .f.t.f -x 0 -y 0
|
|
frame .f.t.f.f -width 100 -height 100 -relief raised -bd 2
|
|
place .f.t.f.f -relx 1 -rely 1 -anchor se
|
|
update
|
|
destroy .f
|
|
} {}
|
|
|
|
test window-2.1 {Tk_NameToWindow procedure} {
|
|
catch {destroy .t}
|
|
list [catch {winfo geometry .t} msg] $msg
|
|
} {1 {bad window path name ".t"}}
|
|
test window-2.2 {Tk_NameToWindow procedure} {
|
|
catch {destroy .t}
|
|
frame .t -width 100 -height 50
|
|
place .t -x 10 -y 10
|
|
update
|
|
list [catch {winfo geometry .t} msg] $msg
|
|
} {0 100x50+10+10}
|