diff options
Diffstat (limited to 'tests/interp.test')
| -rw-r--r-- | tests/interp.test | 133 |
1 files changed, 99 insertions, 34 deletions
diff --git a/tests/interp.test b/tests/interp.test index 919774f..4c43edb 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) interp.test 1.64 97/09/04 16:02:23 +# SCCS: @(#) interp.test 1.70 98/02/17 23:45:11 if {[string compare test [info procs test]] == 1} then {source defs} @@ -39,7 +39,7 @@ test interp-1.3 {options for interp command} { } "" test interp-1.4 {options for interp command} { list [catch {interp delete foo bar} msg] $msg -} {1 {interpreter named "foo" not found}} +} {1 {could not find interpreter "foo"}} test interp-1.5 {options for interp command} { list [catch {interp exists foo bar} msg] $msg } {1 {wrong # args: should be "interp exists ?path?"}} @@ -83,7 +83,7 @@ test interp-2.6 {basic interpreter creation} { } d test interp-2.7 {basic interpreter creation} { list [catch {interp create -froboz} msg] $msg -} {1 {bad option "-froboz": should be -safe}} +} {1 {bad option "-froboz": must be -safe or --}} test interp-2.8 {basic interpreter creation} { interp create -- -froboz } -froboz @@ -99,17 +99,15 @@ test interp-2.11 {anonymous interps vs existing procs} { set x [interp create] regexp "interp(\[0-9]+)" $x dummy thenum interp delete $x - incr thenum proc interp$thenum {} {} set x [interp create] regexp "interp(\[0-9]+)" $x dummy anothernum - expr $anothernum - $thenum + expr $anothernum > $thenum } 1 test interp-2.12 {anonymous interps vs existing procs} { set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy thenum interp delete $x - incr thenum proc interp$thenum {} {} set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy anothernum @@ -164,10 +162,10 @@ test interp-4.1 {testing interp delete} { } "" test interp-4.2 {testing interp delete} { list [catch {interp delete nonexistent} msg] $msg -} {1 {interpreter named "nonexistent" not found}} +} {1 {could not find interpreter "nonexistent"}} test interp-4.3 {testing interp delete} { list [catch {interp delete x y z} msg] $msg -} {1 {interpreter named "x" not found}} +} {1 {could not find interpreter "x"}} test interp-4.4 {testing interp delete} { interp delete } "" @@ -187,7 +185,7 @@ test interp-4.7 {testing interp delete} { interp create c1 interp create c2 list [catch {interp delete c1 c2 c3} msg] $msg -} {1 {interpreter named "c3" not found}} +} {1 {could not find interpreter "c3"}} foreach i [interp slaves] { interp delete $i @@ -1594,7 +1592,7 @@ test interp-22.5 {testing interp marktrusted} { catch {a eval {interp marktrusted b}} msg interp delete a set msg -} {"interp marktrusted" can only be invoked from a trusted interpreter} +} {permission denied: safe interpreter cannot mark trusted} test interp-22.6 {testing interp marktrusted} { catch {interp delete a} interp create a -safe @@ -1602,7 +1600,7 @@ test interp-22.6 {testing interp marktrusted} { catch {a eval {b marktrusted}} msg interp delete a set msg -} {"b marktrusted" can only be invoked from a trusted interpreter} +} {permission denied: safe interpreter cannot mark trusted} test interp-22.7 {testing interp marktrusted} { catch {interp delete a} interp create a -safe @@ -1929,31 +1927,91 @@ test interp-25.1 {testing aliasing of string commands} { } "" +# # Interps result transmission -test interp-26.1 {result code transmission 1} {knownBug} { - # This test currently fails ! (only ok/error are passed, not the other - # codes). Fixing the code is thus needed... -- dl - # (the only other acceptable result list would be - # {-1 0 1 0 3 4 5} because of the way return -code return(=2) works) - # test that all the possibles error codes from Tcl get passed +# + +test interp-26.1 {result code transmission : interp eval direct} { + # Test that all the possibles error codes from Tcl get passed up + # from the slave interp's context to the master, even though the + # slave nominally thinks the command is running at the root level. + + catch {interp delete a} + interp create a + set res {} + # use a for so if a return -code break 'escapes' we would notice + for {set code -1} {$code<=5} {incr code} { + lappend res [catch {interp eval a return -code $code} msg] + } + interp delete a + set res +} {-1 0 1 2 3 4 5} + + +test interp-26.2 {result code transmission : interp eval indirect} { + # retcode == 2 == return is special catch {interp delete a} interp create a - interp eval a {proc ret {code} {return -code $code $code}} + interp eval a {proc retcode {code} {return -code $code ret$code}} set res {} # use a for so if a return -code break 'escapes' we would notice for {set code -1} {$code<=5} {incr code} { - lappend res [catch {interp eval a ret $code} msg] + lappend res [catch {interp eval a retcode $code} msg] $msg + } + interp delete a + set res +} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} + +test interp-26.3 {result code transmission : aliases} { + # Test that all the possibles error codes from Tcl get passed up + # from the slave interp's context to the master, even though the + # slave nominally thinks the command is running at the root level. + + catch {interp delete a} + interp create a + set res {} + proc MyTestAlias {code} { + return -code $code ret$code + } + interp alias a Test {} MyTestAlias + for {set code -1} {$code<=5} {incr code} { + lappend res [interp eval a [list catch [list Test $code] msg]] + } + interp delete a + set res +} {-1 0 1 2 3 4 5} + +test interp-26.4 {result code transmission : invoke hidden direct} {knownBug} { + # The known bug is that code 2 is returned, not the -code argument + catch {interp delete a} + interp create a + set res {} + interp hide a return + for {set code -1} {$code<=5} {incr code} { + lappend res [catch {interp invokehidden a return -code $code ret$code}] } interp delete a set res } {-1 0 1 2 3 4 5} -test interp-26.2 {result code transmission 2} {knownBug} { - # This test currently fails ! (error is cleared) - # Code fixing is needed... -- dl - # (the only other acceptable result list would be - # {-1 0 1 0 3 4 5} because of the way return -code return(=2) works) - # test that all the possibles error codes from Tcl get passed +test interp-26.5 {result code transmission : invoke hidden indirect} {knownBug} { + # The known bug is that the break and continue should raise errors + # that they are used outside a loop. + catch {interp delete a} + interp create a + set res {} + interp eval a {proc retcode {code} {return -code $code ret$code}} + interp hide a retcode + for {set code -1} {$code<=5} {incr code} { + lappend res [catch {interp invokehidden a retcode $code} msg] $msg + } + interp delete a + set res +} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} + +test interp-26.6 {result code transmission : all combined} {knownBug} { + # Test that all the possibles error codes from Tcl get passed + # In both directions. This doesn't work. set interp [interp create]; proc MyTestAlias {interp args} { global aliasTrace; @@ -1964,17 +2022,22 @@ test interp-26.2 {result code transmission 2} {knownBug} { interp hide $interp $c; interp alias $interp $c {} MyTestAlias $interp $c; } - interp eval $interp {proc ret {code} {return -code $code $code}} + interp eval $interp {proc ret {code} {return -code $code ret$code}} set res {} set aliasTrace {} for {set code -1} {$code<=5} {incr code} { - lappend res [catch {interp eval $interp ret $code} msg] + lappend res [catch {interp eval $interp ret $code} msg] $msg } interp delete $interp; - list $res -} {-1 0 1 2 3 4 5} + set res +} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} -test interp-26.3 {errorInfo transmission : regular interps} { +# Some tests might need to be added to check for difference between +# toplevel and non toplevel evals. + +# End of return code transmission section + +test interp-26.5 {errorInfo transmission : regular interps} { set interp [interp create]; proc MyError {secret} { return -code error "msg" @@ -1989,11 +2052,11 @@ test interp-26.3 {errorInfo transmission : regular interps} { } {msg while executing "MyError "some secret"" - (procedure "test" line 2) + (procedure "MyTestAlias" line 2) invoked from within -"catch test"} +"test"} -test interp-26.4 {errorInfo transmission : safe interps} {knownBug} { +test interp-26.6 {errorInfo transmission : safe interps} {knownBug tasteIssue} { # this test fails because the errorInfo is fully transmitted # whether the interp is safe or not. this is maybe a feature # and not a bug. @@ -2010,7 +2073,7 @@ test interp-26.4 {errorInfo transmission : safe interps} {knownBug} { set res } {msg while executing -"catch test"} +"test"} # Interps & Namespaces test interp-27.1 {interp aliases & namespaces} { @@ -2256,3 +2319,5 @@ test interp-29.2 {recursion limit inheritance} { foreach i [interp slaves] { interp delete $i } + +return |