* 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.


FossilOrigin-Name: cda2e66757f876250dc3756cb11869aca95de027

5 files changed, 79 insertions, 30 deletions

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 {