Import Tk 8.5.15 (as of svn r89086)
This commit is contained in:
Zachary Ware
304
tests/window.test
Normal file
304
tests/window.test
Normal file
@@ -0,0 +1,304 @@
|
||||
# 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.1
|
||||
eval tcltest::configure $argv
|
||||
tcltest::loadTestedCommands
|
||||
testConstraint unthreaded [expr {
|
||||
(![info exist tcl_platform(threaded)] || !$tcl_platform(threaded))
|
||||
}]
|
||||
namespace import -force ::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} {
|
||||
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-2.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-2.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-2.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.4 {Tk_DestroyWindow, cleanup half dead window at exit} \
|
||||
unixOrWin {
|
||||
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
|
||||
} {0 {}}
|
||||
|
||||
test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} \
|
||||
unixOrWin {
|
||||
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
|
||||
} {0 {}}
|
||||
|
||||
test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} \
|
||||
unixOrWin {
|
||||
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
|
||||
} {0 {}}
|
||||
|
||||
test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} \
|
||||
unixOrWin {
|
||||
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
|
||||
} {0 {}}
|
||||
|
||||
test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \
|
||||
unixOrWin {
|
||||
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
|
||||
} {0 {}}
|
||||
|
||||
# window-2.9 deadlocks threaded Tk [Bug 1715716]
|
||||
test window-2.9 {Tk_DestroyWindow, Destroy bindings
|
||||
evaluated after exit} {unixOrWin unthreaded} {
|
||||
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
|
||||
} {0 {Destroy .t2
|
||||
Destroy .t1}}
|
||||
|
||||
test window-2.10 {Tk_DestroyWindow, Destroy binding
|
||||
evaluated once} unixOrWin {
|
||||
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
|
||||
} {0 {Destroy .}}
|
||||
|
||||
test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \
|
||||
unixOrWin {
|
||||
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
|
||||
} {0 YES}
|
||||
|
||||
test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \
|
||||
{unix testmenubar} {
|
||||
catch {destroy .t}
|
||||
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.
|
||||
} {}
|
||||
test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} \
|
||||
{unix testmenubar} {
|
||||
catch {destroy .t}
|
||||
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.
|
||||
} {}
|
||||
|
||||
test window-4.1 {Tk_NameToWindow procedure} {testmenubar} {
|
||||
catch {destroy .t}
|
||||
list [catch {winfo geometry .t} msg] $msg
|
||||
} {1 {bad window path name ".t"}}
|
||||
test window-4.2 {Tk_NameToWindow procedure} {testmenubar} {
|
||||
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}
|
||||
|
||||
test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \
|
||||
{unix testmenubar} {
|
||||
catch {destroy .t}
|
||||
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
|
||||
cleanupTests
|
||||
return
|
||||
Reference in New Issue
Block a user