diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | generic/tclInterp.c | 4 | ||||
| -rw-r--r-- | tests/basic.test | 22 | ||||
| -rw-r--r-- | tests/io.test | 49 | ||||
| -rw-r--r-- | tests/socket.test | 55 | ||||
| -rw-r--r-- | tests/timer.test | 20 |
6 files changed, 109 insertions, 50 deletions
@@ -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)}}} |