385 lines
9.7 KiB
Plaintext
385 lines
9.7 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.
|
|
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
|
# All rights reserved.
|
|
|
|
package require tcltest 2.2
|
|
namespace import ::tcltest::*
|
|
tcltest::configure {*}$argv
|
|
tcltest::loadTestedCommands
|
|
namespace import ::tk::test::loadTkCommand
|
|
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} -setup {
|
|
destroy .t
|
|
} -body {
|
|
proc bgerror msg {
|
|
global x errorInfo
|
|
set x [list $msg $errorInfo]
|
|
}
|
|
|
|
set x unchanged
|
|
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
|
|
set x
|
|
} -cleanup {
|
|
rename bgerror {}
|
|
} -result {{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-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup {
|
|
destroy .t
|
|
} -body {
|
|
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
|
|
} -result {}
|
|
test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup {
|
|
destroy .t
|
|
} -body {
|
|
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
|
|
} -result {}
|
|
test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup {
|
|
destroy .f
|
|
} -body {
|
|
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
|
|
} -result {}
|
|
|
|
test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} -constraints {
|
|
unixOrWin
|
|
} -body {
|
|
set code [loadTkCommand]
|
|
append code {
|
|
update
|
|
bind . <Destroy> exit
|
|
destroy .
|
|
}
|
|
set script [makeFile $code script]
|
|
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
|
|
set error 1
|
|
} else {
|
|
set error 0
|
|
}
|
|
removeFile script
|
|
list $error $msg
|
|
} -result {0 {}}
|
|
|
|
test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints {
|
|
unixOrWin
|
|
} -body {
|
|
set code [loadTkCommand]
|
|
append code {
|
|
toplevel .t
|
|
update
|
|
bind .t <Destroy> exit
|
|
destroy .t
|
|
}
|
|
set script [makeFile $code script]
|
|
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
|
|
set error 1
|
|
} else {
|
|
set error 0
|
|
}
|
|
removeFile script
|
|
list $error $msg
|
|
} -result {0 {}}
|
|
|
|
test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints {
|
|
unixOrWin
|
|
} -body {
|
|
set code [loadTkCommand]
|
|
append code {
|
|
toplevel .t
|
|
update
|
|
bind .t <Destroy> exit
|
|
destroy .
|
|
}
|
|
set script [makeFile $code script]
|
|
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
|
|
set error 1
|
|
} else {
|
|
set error 0
|
|
}
|
|
removeFile script
|
|
list $error $msg
|
|
} -result {0 {}}
|
|
|
|
test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints {
|
|
unixOrWin
|
|
} -body {
|
|
set code [loadTkCommand]
|
|
append code {
|
|
toplevel .t
|
|
toplevel .t.f
|
|
update
|
|
bind .t.f <Destroy> exit
|
|
destroy .
|
|
}
|
|
set script [makeFile $code script]
|
|
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
|
|
set error 1
|
|
} else {
|
|
set error 0
|
|
}
|
|
removeFile script
|
|
list $error $msg
|
|
} -result {0 {}}
|
|
|
|
test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints {
|
|
unixOrWin
|
|
} -body {
|
|
set code [loadTkCommand]
|
|
append code {
|
|
toplevel .t1
|
|
toplevel .t2
|
|
toplevel .t3
|
|
update
|
|
bind .t3 <Destroy> {destroy .t2}
|
|
bind .t2 <Destroy> {destroy .t1}
|
|
bind .t1 <Destroy> {exit 0}
|
|
destroy .t3
|
|
}
|
|
set script [makeFile $code script]
|
|
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
|
|
set error 1
|
|
} else {
|
|
set error 0
|
|
}
|
|
removeFile script
|
|
list $error $msg
|
|
} -result {0 {}}
|
|
|
|
test window-2.9 {Tk_DestroyWindow, Destroy bindings evaluated after exit} -constraints {
|
|
unixOrWin
|
|
} -body {
|
|
set code [loadTkCommand]
|
|
append code {
|
|
toplevel .t1
|
|
toplevel .t2
|
|
update
|
|
bind .t2 <Destroy> {puts "Destroy .t2" ; exit 1}
|
|
bind .t1 <Destroy> {puts "Destroy .t1" ; exit 0}
|
|
destroy .t2
|
|
}
|
|
set script [makeFile $code script]
|
|
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
|
|
set error 1
|
|
} else {
|
|
set error 0
|
|
}
|
|
removeFile script
|
|
list $error $msg
|
|
} -result {0 {Destroy .t2
|
|
Destroy .t1}}
|
|
|
|
test window-2.10 {Tk_DestroyWindow, Destroy binding evaluated once} -constraints {
|
|
unixOrWin
|
|
} -body {
|
|
set code [loadTkCommand]
|
|
append code {
|
|
update
|
|
bind . <Destroy> {
|
|
puts "Destroy ."
|
|
bind . <Destroy> {puts "Re-Destroy ."}
|
|
exit 0
|
|
}
|
|
destroy .
|
|
}
|
|
set script [makeFile $code script]
|
|
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
|
|
set error 1
|
|
} else {
|
|
set error 0
|
|
}
|
|
removeFile script
|
|
list $error $msg
|
|
} -result {0 {Destroy .}}
|
|
|
|
test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} -constraints {
|
|
unixOrWin
|
|
} -body {
|
|
set code [loadTkCommand]
|
|
append code {
|
|
toplevel .t1
|
|
toplevel .t2
|
|
update
|
|
bind .t1 <Destroy> {
|
|
if {[catch {entry .t2.newchild}]} {
|
|
puts YES
|
|
} else {
|
|
puts NO
|
|
}
|
|
}
|
|
bind .t2 <Destroy> {exit}
|
|
destroy .t2
|
|
}
|
|
set script [makeFile $code script]
|
|
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
|
|
set error 1
|
|
} else {
|
|
set error 0
|
|
}
|
|
removeFile script
|
|
list $error $msg
|
|
} -result {0 YES}
|
|
|
|
test window-2.12 {Test for ticket [9b6065d1fd] - restore Tcl [update] command} -constraints {
|
|
unixOrWin
|
|
} -body {
|
|
set code [loadTkCommand]
|
|
append code {
|
|
after 1000 {set forever 1}
|
|
after 100 {destroy .}
|
|
after 200 {catch bell msg; puts "ringing the bell -> $msg"}
|
|
after 250 {update idletasks}
|
|
after 300 {update}
|
|
puts "waiting"
|
|
vwait forever
|
|
puts "done waiting"
|
|
catch {bell} msg
|
|
puts "bell -> $msg"
|
|
catch update msg
|
|
puts "update -> $msg"
|
|
}
|
|
set script [makeFile $code script]
|
|
if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
|
|
set error 1
|
|
} else {
|
|
set error 0
|
|
}
|
|
removeFile script
|
|
list $error $msg
|
|
} -result {0 {waiting
|
|
ringing the bell -> can't invoke "bell" command: application has been destroyed
|
|
done waiting
|
|
bell -> can't invoke "bell" command: application has been destroyed
|
|
update -> }}
|
|
|
|
|
|
test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints {
|
|
unix testmenubar
|
|
} -setup {
|
|
destroy .t
|
|
} -body {
|
|
toplevel .t -width 300 -height 200
|
|
wm geometry .t +0+0
|
|
pack [entry .t.e]
|
|
frame .t.f -bd 2 -relief raised
|
|
testmenubar window .t .t.f
|
|
update
|
|
# If stacking order isn't handle properly, generates an X error.
|
|
} -cleanup {
|
|
destroy .t
|
|
} -result {}
|
|
test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints {
|
|
unix testmenubar
|
|
} -setup {
|
|
destroy .t
|
|
} -body {
|
|
toplevel .t -width 300 -height 200
|
|
wm geometry .t +0+0
|
|
pack [entry .t.e]
|
|
pack [entry .t.e2]
|
|
update
|
|
frame .t.f -bd 2 -relief raised
|
|
raise .t.f .t.e
|
|
testmenubar window .t .t.f
|
|
update
|
|
# If stacking order isn't handled properly, generates an X error.
|
|
} -cleanup {
|
|
destroy .t
|
|
} -result {}
|
|
|
|
|
|
test window-4.1 {Tk_NameToWindow procedure} -constraints {
|
|
testmenubar
|
|
} -setup {
|
|
destroy .t
|
|
} -body {
|
|
winfo geometry .t
|
|
} -cleanup {
|
|
destroy .t
|
|
} -returnCodes error -result {bad window path name ".t"}
|
|
test window-4.2 {Tk_NameToWindow procedure} -constraints {
|
|
testmenubar
|
|
} -setup {
|
|
destroy .t
|
|
} -body {
|
|
frame .t -width 100 -height 50
|
|
place .t -x 10 -y 10
|
|
update
|
|
winfo geometry .t
|
|
} -cleanup {
|
|
destroy .t
|
|
} -returnCodes ok -result {100x50+10+10}
|
|
|
|
|
|
test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints {
|
|
unix testmenubar
|
|
} -setup {
|
|
destroy .t
|
|
} -body {
|
|
toplevel .t -width 300 -height 200
|
|
wm geometry .t +0+0
|
|
pack [entry .t.e]
|
|
pack [entry .t.e2]
|
|
frame .t.f -bd 2 -relief raised
|
|
testmenubar window .t .t.f
|
|
update
|
|
lower .t.e2 .t.f
|
|
update
|
|
# If stacking order isn't handled properly, generates an X error.
|
|
} -cleanup {
|
|
destroy .t
|
|
} -result {}
|
|
|
|
|
|
|
|
# cleanup
|
|
cleanupTests
|
|
return
|
|
|
|
# Local variables:
|
|
# mode: tcl
|
|
# End:
|