* tests/basic.test: Updated functional (not testing) uses of

        * tests/io.test:        [bgerror] to make use of [interp bgerror].
        * tests/socket.test:
        * tests/timer.test:

        * generic/tclInterp.c:  Corrected [interp bgerror] error message.

6 files changed, 109 insertions, 50 deletions

diff --git a/ChangeLog b/ChangeLog
index f891857..5c1ac3d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2004-11-18  Don Porter  <dgp@users.sourceforge.net>
+
+	* tests/basic.test:	Updated functional (not testing) uses of
+	* tests/io.test:	[bgerror] to make use of [interp bgerror].
+	* tests/socket.test:
+	* tests/timer.test:
+
+	* generic/tclInterp.c:	Corrected [interp bgerror] error message.
+
 2004-11-18  Reinhard Max  <max@suse.de>
 
 	* unix/tcl.m4 (SC_CONFIG_MANPAGES): Applied an improved version of
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index e0e3582..8f968ba 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInterp.c,v 1.49 2004/11/13 00:19:09 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.50 2004/11/18 19:22:12 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -624,7 +624,7 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv)
 	    Tcl_Interp *slaveInterp;
 
 	    if (objc != 3 && objc != 4) {
-		Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
+		Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?");
 		return TCL_ERROR;
 	    }
 	    slaveInterp = GetInterp(interp, objv[2]);
diff --git a/tests/basic.test b/tests/basic.test
index dcd3a8a..da5449b 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -15,7 +15,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: basic.test,v 1.35 2004/10/26 16:46:15 dgp Exp $
+# RCS: @(#) $Id: basic.test,v 1.36 2004/11/18 19:22:12 dgp Exp $
 #
 
 package require tcltest 2
@@ -414,23 +414,29 @@ test basic-24.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to
 test basic-25.1 {TclCleanupCommand} {emptyTest} {
 } {}
 
-test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} {
+test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} -setup {
+    proc myHandler {msg options} {
+	set ::x [dict get $options -errorinfo]
+    }
+    set handler [interp bgerror {}]
+    interp bgerror {} [namespace which myHandler]
+    set fName [makeFile {} test1]
+} -body {
     # If object isn't preserved, errorInfo would be set to
     # "foo\n    while executing\n\"garbage bytes\"" because the object's
     # string would have been freed, leaving garbage bytes for the error
     # message.
-
-    proc bgerror {args} {set ::x $::errorInfo}
-    set fName [makeFile {} test1]
     set f [open $fName w]
     fileevent $f writable "fileevent $f writable {}; error foo"
     set x {}
     vwait x
     close $f
-    removeFile test1
-    rename bgerror {}
     set x
-} "foo\n    while executing\n\"error foo\""
+} -cleanup {
+    removeFile test1
+    interp bgerror {} $handler
+    rename myHandler {}
+} -result "foo\n    while executing\n\"error foo\""
 
 test basic-27.1 {Tcl_ExprLong} {emptyTest} {
 } {}
diff --git a/tests/io.test b/tests/io.test
index de7cb3a..6545815 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -12,7 +12,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: io.test,v 1.64 2004/11/11 01:16:06 das Exp $
+# RCS: @(#) $Id: io.test,v 1.65 2004/11/18 19:22:12 dgp Exp $
 
 if {[catch {package require tcltest 2}]} {
     puts stderr "Skipping tests in [info script].  tcltest 2 required."
@@ -5380,15 +5380,23 @@ test io-44.1 {FileEventProc procedure: normal read event} {stdio unixExecs filee
     vwait [namespace which -variable x]
     set x
 } {text}
-test io-44.2 {FileEventProc procedure: error in read event} {stdio unixExecs fileevent} {
-    proc ::bgerror args "set [namespace which -variable x] \$args"
+test io-44.2 {FileEventProc procedure: error in read event} -constraints {
+    stdio unixExecs fileevent
+} -setup {
+    proc myHandler {msg options} {
+	variable x $msg
+    }
+    set handler [interp bgerror {}]
+    interp bgerror {} [namespace which myHandler]
+} -body {
     fileevent $f2 readable {error bogus}
     puts $f2 text; flush $f2
     variable x initial
     vwait [namespace which -variable x]
-    rename ::bgerror {}
     list $x [fileevent $f2 readable]
-} {bogus {}}
+} -cleanup {
+    interp bgerror {} $handler
+} -result {bogus {}}
 test io-44.3 {FileEventProc procedure: normal write event} {stdio unixExecs fileevent} {
     fileevent $f2 writable [namespace code {
 	lappend x "triggered"
@@ -5404,14 +5412,22 @@ test io-44.3 {FileEventProc procedure: normal write event} {stdio unixExecs file
     vwait [namespace which -variable x]
     set x
 } {initial triggered triggered triggered}
-test io-44.4 {FileEventProc procedure: eror in write event} {stdio unixExecs fileevent} {
-    proc ::bgerror args "set [namespace which -variable x] \$args"
+test io-44.4 {FileEventProc procedure: eror in write event} -constraints {
+    stdio unixExecs fileevent
+} -setup {
+    proc myHandler {msg options} {
+	variable x $msg
+    }
+    set handler [interp bgerror {}]
+    interp bgerror {} [namespace which myHandler]
+} -body {
     fileevent $f2 writable {error bad-write}
     variable x initial
     vwait [namespace which -variable x]
-    rename ::bgerror {}
     list $x [fileevent $f2 writable]
-} {bad-write {}}
+} -cleanup {
+    interp bgerror {} $handler
+} -result {bad-write {}}
 test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} {
     set f4 [open "|[list [interpreter] $path(cat) << foo]" r]
     fileevent $f4 readable [namespace code {
@@ -6898,7 +6914,9 @@ test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileeve
 
 set path(fooBar) [makeFile {} fooBar]
 
-test io-55.1 {ChannelEventScriptInvoker: deletion} {fileevent} {
+test io-55.1 {ChannelEventScriptInvoker: deletion} -constraints {
+    fileevent
+} -setup {
     variable x
     proc eventScript {fd} {
 	variable x
@@ -6906,13 +6924,20 @@ test io-55.1 {ChannelEventScriptInvoker: deletion} {fileevent} {
 	error "planned error"
 	set x whoops
     }
-    proc ::bgerror {args} "set [namespace which -variable x] got_error"
+    proc myHandler args {
+	variable x got_error
+    }
+    set handler [interp bgerror {}]
+    interp bgerror {} [namespace which myHandler]
+} -body {
     set f [open $path(fooBar) w]
     fileevent $f writable [namespace code [list eventScript $f]]
     variable x not_done
     vwait [namespace which -variable x]
     set x
-} {got_error}
+} -cleanup {
+    interp bgerror {} $handler
+} -result {got_error}
 
 test io-56.1 {ChannelTimerProc} {testchannelevent} {
     set f [open $path(fooBar) w]
diff --git a/tests/socket.test b/tests/socket.test
index 8b6e383..27d95af 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -10,7 +10,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: socket.test,v 1.35 2004/11/04 00:23:52 dgp Exp $
+# RCS: @(#) $Id: socket.test,v 1.36 2004/11/18 19:22:14 dgp Exp $
 
 # Running socket tests with a remote server:
 # ------------------------------------------
@@ -769,8 +769,14 @@ test socket-5.3 {byte order problems, socket numbers, htons} \
     set x
 } {couldn't open socket: not owner}
 
-test socket-6.1 {accept callback error} {socket stdio} {
+test socket-6.1 {accept callback error} -constraints {socket stdio} -setup {
+    proc myHandler {msg options} {
+	variable x $msg
+    }
+    set handler [interp bgerror {}]
+    interp bgerror {} [namespace which myHandler]
     file delete $path(script)
+} -body {
     set f [open $path(script) w]
     puts $f {
 	gets stdin port
@@ -778,10 +784,6 @@ test socket-6.1 {accept callback error} {socket stdio} {
     }
     close $f
     set f [open "|[list [interpreter] $path(script)]" r+]
-    proc bgerror args {
-	global x
-	set x $args
-    }
     proc accept {s a p} {expr 10 / 0}
     set s [socket -server accept 0]
     puts $f [lindex [fconfigure $s -sockname] 2]
@@ -790,9 +792,10 @@ test socket-6.1 {accept callback error} {socket stdio} {
     vwait x
     after cancel $timer
     close $s
-    rename bgerror {}
     set x
-} {{divide by zero}}
+} -cleanup {
+    interp bgerror {} $handler
+} -result {divide by zero}
 
 test socket-7.1 {testing socket specific options} {socket stdio} {
     file delete $path(script)
@@ -1043,9 +1046,16 @@ test socket-9.3 {testing EOF stickyness} {socket} {
 
 removeFile script
 
-test socket-10.1 {testing socket accept callback error handling} {socket} {
-    set goterror 0
-    proc bgerror args {global goterror; set goterror 1}
+test socket-10.1 {testing socket accept callback error handling} -constraints {
+    socket
+} -setup {
+    variable goterror 0
+    proc myHandler {msg options} {
+	variable goterror 1
+    }
+    set handler [interp bgerror {}]
+    interp bgerror {} [namespace which myHandler]
+} -body {
     set s [socket -server accept 0]
     proc accept {s a p} {close $s; error}
     set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
@@ -1053,7 +1063,9 @@ test socket-10.1 {testing socket accept callback error handling} {socket} {
     close $s
     close $c
     set goterror
-} 1
+} -cleanup {
+    interp bgerror {} $handler
+} -result 1
 
 test socket-11.1 {tcp connection} {socket doTestsWithRemoteServer} {
     sendCommand {
@@ -1228,13 +1240,17 @@ test socket-11.8 {client with several servers} {socket doTestsWithRemoteServer}
     }
     set l
 } {4003 {} 1 4004 {} 1 4005 {} 1}
-test socket-11.9 {accept callback error} {socket doTestsWithRemoteServer} {
+test socket-11.9 {accept callback error} -constraints {
+    socket doTestsWithRemoteServer
+} -setup {
+    proc myHandler {msg options} {
+	variable x $msg
+    }
+    set handler [interp bgerror {}]
+    interp bgerror {} [namespace which myHandler]
+} -body {
     set s [socket -server accept 2836]
     proc accept {s a p} {expr 10 / 0}
-    proc bgerror args {
-	global x
-	set x $args
-    }
     if {[catch {sendCommand {
 	    set peername [fconfigure $callerSocket -peername]
 	    set s [socket [lindex $peername 0] 2836]
@@ -1247,9 +1263,10 @@ test socket-11.9 {accept callback error} {socket doTestsWithRemoteServer} {
     vwait x
     after cancel $timer
     close $s
-    rename bgerror {}
     set x
-} {{divide by zero}}
+} -cleanup {
+    interp bgerror {} $handler
+} -result {divide by zero}
 test socket-11.10 {testing socket specific options} {socket doTestsWithRemoteServer} {
     sendCommand {
 	set socket10_12_test_server [socket -server accept 2836]
diff --git a/tests/timer.test b/tests/timer.test
index 2954507..800857b 100644
--- a/tests/timer.test
+++ b/tests/timer.test
@@ -13,7 +13,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: timer.test,v 1.10 2004/09/07 19:12:42 kennykb Exp $
+# RCS: @(#) $Id: timer.test,v 1.11 2004/11/18 19:22:14 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -455,20 +455,22 @@ test timer-8.1 {AfterProc procedure} {
     }
     list [foo] $x
 } {untouched after}
-test timer-8.2 {AfterProc procedure} {
-    catch {rename bgerror {}}
-    proc bgerror msg {
-	global x errorInfo
-	set x [list $msg $errorInfo]
+test timer-8.2 {AfterProc procedure} -setup {
+    variable x empty
+    proc myHandler {msg options} {
+	variable x [list $msg [dict get $options -errorinfo]]
     }
-    set x empty
+    set handler [interp bgerror {}]
+    interp bgerror {} [namespace which myHandler]
+} -body {
     after 100 {error "After error"}
     after 200
     set y $x
     update
-    catch {rename bgerror {}}
     list $y $x
-} {empty {{After error} {After error
+} -cleanup {
+    interp bgerror {} $handler
+} -result {empty {{After error} {After error
     while executing
 "error "After error""
     ("after" script)}}}