diff options
Diffstat (limited to 'tests/interp.test')
| -rw-r--r-- | tests/interp.test | 179 |
1 files changed, 135 insertions, 44 deletions
diff --git a/tests/interp.test b/tests/interp.test index da0c433..817ef99 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -5,21 +5,23 @@ # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998 by Scriptics Corporation. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: interp.test,v 1.6 1999/02/03 02:58:41 stanton Exp $ +# RCS: @(#) $Id: interp.test,v 1.7 1999/04/16 00:47:29 stanton Exp $ -if {[string compare test [info procs test]] == 1} then {source defs} +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] +} # The set of hidden commands is platform dependent: if {"$tcl_platform(platform)" == "macintosh"} { - set hidden_cmds {beep cd echo exit fconfigure file glob load ls open pwd socket source} + set hidden_cmds {beep cd echo encoding exit fconfigure file glob load ls open pwd socket source} } else { - set hidden_cmds {cd exec exit fconfigure file glob load open pwd socket source} + set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source} } foreach i [interp slaves] { @@ -40,7 +42,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?"}} @@ -84,7 +86,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 @@ -100,17 +102,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 @@ -165,10 +165,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 } "" @@ -188,10 +188,10 @@ 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"}} test interp-4.8 {testing interp delete} { list [catch {interp delete {}} msg] $msg -} {1 {interpreter named "" not found}} +} {1 {cannot delete the current interpreter}} foreach i [interp slaves] { interp delete $i @@ -1598,7 +1598,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 @@ -1606,7 +1606,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 @@ -1666,7 +1666,7 @@ test interp-23.1 {testing hiding vs aliases} { interp delete a set l } {{} bar {} bar bar {} {}} -test interp-23.2 {testing hiding vs aliases} {pc || unix} { +test interp-23.2 {testing hiding vs aliases} {unixOrPc} { catch {interp delete a} interp create a -safe set l "" @@ -1682,7 +1682,7 @@ test interp-23.2 {testing hiding vs aliases} {pc || unix} { lappend l [lsort [interp hidden a]] interp delete a set l -} {{cd exec exit fconfigure file glob load open pwd socket source} bar {cd exec exit fconfigure file glob load open pwd socket source} bar {bar cd exec exit fconfigure file glob load open pwd socket source} {} {cd exec exit fconfigure file glob load open pwd socket source}} +} {{cd encoding exec exit fconfigure file glob load open pwd socket source} bar {cd encoding exec exit fconfigure file glob load open pwd socket source} bar {bar cd encoding exec exit fconfigure file glob load open pwd socket source} {} {cd encoding exec exit fconfigure file glob load open pwd socket source}} test interp-23.3 {testing hiding vs aliases} {macOnly} { catch {interp delete a} @@ -1933,31 +1933,94 @@ 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 - interp eval a {proc ret {code} {return -code $code $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 return -code $code} msg] } 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.2 {result code transmission : interp eval indirect} { + # retcode == 2 == return is special + catch {interp delete a} + interp create a + 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 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--bug 1637} \ + {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.5 {result code transmission: invoke hidden indirect--bug 1637} \ + {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--bug 1637} \ + {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; @@ -1968,17 +2031,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} + +# 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.3 {errorInfo transmission : regular interps} { +test interp-26.7 {errorInfo transmission: regular interps} { set interp [interp create]; proc MyError {secret} { return -code error "msg" @@ -1993,14 +2061,15 @@ 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.8 {errorInfo transmission: safe interps--bug 1637} {knownBug} { # 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. + # whether the interp is safe or not. The errorInfo should never + # report data from the master interpreter because it could + # contain sensitive information. set interp [interp create -safe]; proc MyError {secret} { return -code error "msg" @@ -2014,7 +2083,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} { @@ -2163,7 +2232,7 @@ test interp-27.4 {interp aliases & namespaces} { # namespace delete mfoo; # interp delete $i; # set res -# } {{slave bar called (foo-slave) (bar test1) (::test) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}} +# } {{slave bar called (foo-slave) (bar test1) (::tcltest) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}} #test interp-27.8 {hiding, namespaces and integrity} { # namespace eval foo { @@ -2264,6 +2333,28 @@ test interp-30.1 {deletion of aliases inside namespaces} { $i alias ns::cmd {} } {} +test interp-31.1 {alias invocation scope} { + proc mySet {varName value} { + upvar 1 $varName localVar + set localVar $value + } + + interp alias {} myNewSet {} mySet + proc testMyNewSet {value} { + myNewSet a $value + return $a + } + catch {unset a} + set result [testMyNewSet "ok"] + rename testMyNewSet {} + rename mySet {} + rename myNewSet {} + set result +} ok + +# cleanup foreach i [interp slaves] { interp delete $i } +::tcltest::cleanupTests +return |