summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog9
-rw-r--r--generic/tclInterp.c4
-rw-r--r--tests/basic.test22
-rw-r--r--tests/io.test49
-rw-r--r--tests/socket.test55
-rw-r--r--tests/timer.test20
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)}}}