diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | tests/constraints.tcl | 17 | ||||
| -rw-r--r-- | tests/image.test | 15 | ||||
| -rw-r--r-- | tests/select.test | 10 | ||||
| -rw-r--r-- | tests/unixWm.test | 16 | ||||
| -rw-r--r-- | tests/window.test | 51 |
6 files changed, 88 insertions, 30 deletions
@@ -1,3 +1,12 @@ +2003-11-17 Don Porter <dgp@users.sourceforge.net> + + * tests/constraints.tcl:When running the test suite in a process + * tests/image.test: where Tk has been [load]ed, there's no + * tests/select.test: guarantee that child processes created by + * tests/unixWm.test: [exec [interpreter]] will have Tk in them. + * tests/window.test: Made modifications to force a [load] of Tk + in those situations. + 2003-11-17 Jeff Hobbs <jeffh@ActiveState.com> * generic/tkMenubutton.h: fixed compound menubutton handling like diff --git a/tests/constraints.tcl b/tests/constraints.tcl index f8c7a59..2da8938 100644 --- a/tests/constraints.tcl +++ b/tests/constraints.tcl @@ -23,10 +23,25 @@ package require tcltest 2.1 namespace eval tk { namespace eval test { + + namespace export loadTkCommand + proc loadTkCommand {} { + set tklib {} + foreach pair [info loaded {}] { + foreach {lib pfx} $pair break + if {$pfx eq "Tk"} { + set tklib $lib + break + } + } + return [list load $tklib Tk] + } + namespace eval bg { # Manage a background process. # Replace with slave interp or thread? namespace import ::tcltest::interpreter + namespace import ::tk::test::loadTkCommand namespace export setup cleanup do proc cleanup {} { @@ -52,6 +67,8 @@ namespace eval tk { error "unexpected output from\ background process: \"$data\"" } + puts $fd [loadTkCommand] + flush $fd fileevent $fd readable [namespace code Ready] } proc Ready {} { diff --git a/tests/image.test b/tests/image.test index d318713..be119e6 100644 --- a/tests/image.test +++ b/tests/image.test @@ -7,11 +7,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: image.test,v 1.11 2003/09/17 23:45:35 dgp Exp $ +# RCS: @(#) $Id: image.test,v 1.12 2003/11/18 01:47:51 dgp Exp $ package require tcltest 2.1 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force ::tk::test::loadTkCommand eval image delete [image names] canvas .c -highlightthickness 2 @@ -67,21 +68,25 @@ test image-1.9 {Tk_ImageCmd procedure, "create" option} testImageType { list [catch {image create test -badName foo} msg] $msg [image names] } {1 {bad option name "-badName"} {}} test image-1.10 {Tk_ImageCmd procedure, "create" option with same name as main window} { - set script [makeFile { + set code [loadTkCommand] + append code { update puts [list [catch {image create photo .} msg] $msg] exit - } script] + } + set script [makeFile $code script] set x [list [catch {exec [interpreter] <$script} msg] $msg] removeFile script set x } {0 {1 {images may not be named the same as the main window}}} test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} { - set script [makeFile { + set code [loadTkCommand] + append code { update puts [list [catch {rename . foo;image create photo foo} msg] $msg] exit - } script] + } + set script [makeFile $code script] set x [list [catch {exec [interpreter] <$script} msg] $msg] removeFile script set x diff --git a/tests/select.test b/tests/select.test index db401b7..04adc6b 100644 --- a/tests/select.test +++ b/tests/select.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: select.test,v 1.10 2003/04/01 21:06:51 dgp Exp $ +# RCS: @(#) $Id: select.test,v 1.11 2003/11/18 01:47:51 dgp Exp $ # # Note: Multiple display selection handling will only be tested if the @@ -17,6 +17,8 @@ package require tcltest 2.1 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force ::tk::test:loadTkCommand + global longValue selValue selInfo set selValue {} @@ -856,7 +858,7 @@ test select-10.1 {ConvertSelection procedure, race with selection clear} {unixOn lappend x [gets $fd] } set fd [open "|[list [interpreter] -geometry +0+0 -name tktest]" r+] - puts $fd "puts foo; flush stdout" + puts $fd "puts foo; [loadTkCommand]; flush stdout" flush $fd gets $fd fileevent $fd readable [list Ready $fd] @@ -872,7 +874,9 @@ test select-10.1 {ConvertSelection procedure, race with selection clear} {unixOn vwait [namespace which -variable x] puts $fd {exit} flush $fd - close $fd + # Don't understand why, but the [loadTkCommand] above causes + # a "broken pipe" error when Tk was actually [load]ed in the child. + catch {close $fd} lappend x $selInfo } {{1 PRIMARY selection doesn't exist or form "STRING" not defined} {}} test select-10.2 {ConvertSelection procedure} {unixOnly} { diff --git a/tests/unixWm.test b/tests/unixWm.test index a361b3e..aa6da1c 100644 --- a/tests/unixWm.test +++ b/tests/unixWm.test @@ -7,12 +7,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixWm.test,v 1.35 2003/10/15 20:04:03 jenglish Exp $ +# RCS: @(#) $Id: unixWm.test,v 1.36 2003/11/18 01:47:51 dgp Exp $ package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force ::tk::test:loadTkCommand + proc sleep ms { global x after $ms {set x 1} @@ -2394,14 +2396,16 @@ test unixWm-59.1 {exit processing} unix { list $error $msg } {0 {}} test unixWm-59.2 {exit processing} unix { - set script [makeFile { + set code [loadTkCommand] + append code { interp create x x eval {set argc 2} x eval {set argv "-geometry 10x10+0+0"} x eval {load {} Tk} update exit - } script] + } + set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { @@ -2411,7 +2415,8 @@ test unixWm-59.2 {exit processing} unix { list $error $msg } {0 {}} test unixWm-59.3 {exit processing} unix { - set script [makeFile { + set code [loadTkCommand] + append code { interp create x x eval {set argc 2} x eval {set argv "-geometry 10x10+0+0"} @@ -2424,7 +2429,8 @@ test unixWm-59.3 {exit processing} unix { proc destroy_x {} {interp delete x} update exit - } script] + } + set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { diff --git a/tests/window.test b/tests/window.test index 9d62208..db80f97 100644 --- a/tests/window.test +++ b/tests/window.test @@ -5,12 +5,13 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: window.test,v 1.8 2003/04/01 21:07:02 dgp Exp $ +# RCS: @(#) $Id: window.test,v 1.9 2003/11/18 01:47:51 dgp Exp $ package require tcltest 2.1 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force ::tk::test::loadTkCommand update # XXX This file is woefully incomplete. Right now it only tests @@ -76,11 +77,13 @@ test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} { test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} \ unixOrWin { - set script [makeFile { + set code [loadTkCommand] + append code { update bind . <Destroy> exit destroy . - } script] + } + set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { @@ -92,12 +95,14 @@ test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} \ test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} \ unixOrWin { - set script [makeFile { + set code [loadTkCommand] + append code { toplevel .t update bind .t <Destroy> exit destroy .t - } script] + } + set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { @@ -109,12 +114,14 @@ test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} \ test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} \ unixOrWin { - set script [makeFile { + set code [loadTkCommand] + append code { toplevel .t update bind .t <Destroy> exit destroy . - } script] + } + set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { @@ -126,13 +133,15 @@ test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} \ test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} \ unixOrWin { - set script [makeFile { + set code [loadTkCommand] + append code { toplevel .t toplevel .t.f update bind .t.f <Destroy> exit destroy . - } script] + } + set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { @@ -144,7 +153,8 @@ test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} \ test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \ unixOrWin { - set script [makeFile { + set code [loadTkCommand] + append code { toplevel .t1 toplevel .t2 toplevel .t3 @@ -153,7 +163,8 @@ test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \ bind .t2 <Destroy> {destroy .t1} bind .t1 <Destroy> {exit 0} destroy .t3 - } script] + } + set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { @@ -165,14 +176,16 @@ test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \ test window-2.9 {Tk_DestroyWindow, Destroy bindings evaluated after exit} unixOrWin { - set script [makeFile { + 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 - } script] + } + set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { @@ -185,7 +198,8 @@ Destroy .t1}} test window-2.10 {Tk_DestroyWindow, Destroy binding evaluated once} unixOrWin { - set script [makeFile { + set code [loadTkCommand] + append code { update bind . <Destroy> { puts "Destroy ." @@ -193,7 +207,8 @@ test window-2.10 {Tk_DestroyWindow, Destroy binding exit 0 } destroy . - } script] + } + set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { @@ -205,7 +220,8 @@ test window-2.10 {Tk_DestroyWindow, Destroy binding test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \ unixOrWin { - set script [makeFile { + set code [loadTkCommand] + append code { toplevel .t1 toplevel .t2 update @@ -218,7 +234,8 @@ test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \ } bind .t2 <Destroy> {exit} destroy .t2 - } script] + } + set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { |