diff options
Diffstat (limited to 'tests/interp.test')
| -rw-r--r-- | tests/interp.test | 1738 |
1 files changed, 809 insertions, 929 deletions
diff --git a/tests/interp.test b/tests/interp.test index fa263e2..510ab4a 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -4,62 +4,60 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright © 1995-1996 Sun Microsystems, Inc. -# Copyright © 1998-1999 Scriptics Corporation. +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# 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. -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2.1 namespace import -force ::tcltest::* } -::tcltest::loadTestedCommands -catch [list package require -exact tcl::test [info patchlevel]] - testConstraint testinterpdelete [llength [info commands testinterpdelete]] -set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} +set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source unload} -foreach i [interp children] { +foreach i [interp slaves] { interp delete $i } - + # Part 0: Check out options for interp command -test interp-1.1 {options for interp command} -returnCodes error -body { - interp -} -result {wrong # args: should be "interp cmd ?arg ...?"} -test interp-1.2 {options for interp command} -returnCodes error -body { - interp frobox -} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} +test interp-1.1 {options for interp command} { + list [catch {interp} msg] $msg +} {1 {wrong # args: should be "interp cmd ?arg ...?"}} +test interp-1.2 {options for interp command} { + list [catch {interp frobox} msg] $msg +} {1 {bad option "frobox": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} test interp-1.3 {options for interp command} { interp delete } "" -test interp-1.4 {options for interp command} -returnCodes error -body { - interp delete foo bar -} -result {could not find interpreter "foo"} -test interp-1.5 {options for interp command} -returnCodes error -body { - interp exists foo bar -} -result {wrong # args: should be "interp exists ?path?"} +test interp-1.4 {options for interp command} { + list [catch {interp delete foo bar} msg] $msg +} {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?"}} # # test interp-0.6 was removed # -test interp-1.6 {options for interp command} -returnCodes error -body { - interp children foo bar zop -} -result {wrong # args: should be "interp children ?path?"} -test interp-1.7 {options for interp command} -returnCodes error -body { - interp hello -} -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} -test interp-1.8 {options for interp command} -returnCodes error -body { - interp -froboz -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} -test interp-1.9 {options for interp command} -returnCodes error -body { - interp -froboz -safe -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} -test interp-1.10 {options for interp command} -returnCodes error -body { - interp target -} -result {wrong # args: should be "interp target path alias"} +test interp-1.6 {options for interp command} { + list [catch {interp slaves foo bar zop} msg] $msg +} {1 {wrong # args: should be "interp slaves ?path?"}} +test interp-1.7 {options for interp command} { + list [catch {interp hello} msg] $msg +} {1 {bad option "hello": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} +test interp-1.8 {options for interp command} { + list [catch {interp -froboz} msg] $msg +} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} +test interp-1.9 {options for interp command} { + list [catch {interp -froboz -safe} msg] $msg +} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} +test interp-1.10 {options for interp command} { + list [catch {interp target} msg] $msg +} {1 {wrong # args: should be "interp target path alias"}} + # Part 1: Basic interpreter creation tests: test interp-2.1 {basic interpreter creation} { @@ -70,12 +68,10 @@ test interp-2.2 {basic interpreter creation} { } 0 test interp-2.3 {basic interpreter creation} { catch {interp create -safe} -} 0 -test interp-2.4 {basic interpreter creation} -setup { - catch {interp create a} -} -returnCodes error -body { - interp create a -} -result {interpreter named "a" already exists, cannot create} +} 0 +test interp-2.4 {basic interpreter creation} { + list [catch {interp create a} msg] $msg +} {1 {interpreter named "a" already exists, cannot create}} test interp-2.5 {basic interpreter creation} { interp create b -safe } b @@ -91,13 +87,11 @@ test interp-2.8 {basic interpreter creation} { test interp-2.9 {basic interpreter creation} { interp create -safe -- -froboz1 } -froboz1 -test interp-2.10 {basic interpreter creation} -setup { - catch {interp create a} -} -body { +test interp-2.10 {basic interpreter creation} { interp create {a x1} interp create {a x2} interp create {a x3} -safe -} -result {a x3} +} {a x3} test interp-2.11 {anonymous interps vs existing procs} { set x [interp create] regexp "interp(\[0-9]+)" $x dummy thenum @@ -105,8 +99,8 @@ test interp-2.11 {anonymous interps vs existing procs} { proc interp$thenum {} {} set x [interp create] regexp "interp(\[0-9]+)" $x dummy anothernum - expr {$anothernum > $thenum} -} 1 + 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 @@ -114,56 +108,49 @@ test interp-2.12 {anonymous interps vs existing procs} { proc interp$thenum {} {} set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy anothernum - expr {$anothernum - $thenum} -} 1 + expr $anothernum - $thenum +} 1 test interp-2.13 {correct default when no $path arg is given} -body { interp create -- } -match regexp -result {interp[0-9]+} - -foreach i [interp children] { + +foreach i [interp slaves] { interp delete $i } -# Part 2: Testing "interp children" and "interp exists" -test interp-3.1 {testing interp exists and interp children} { - interp children +# Part 2: Testing "interp slaves" and "interp exists" +test interp-3.1 {testing interp exists and interp slaves} { + interp slaves } "" -test interp-3.2 {testing interp exists and interp children} { +test interp-3.2 {testing interp exists and interp slaves} { interp create a interp exists a } 1 -test interp-3.3 {testing interp exists and interp children} { +test interp-3.3 {testing interp exists and interp slaves} { interp exists nonexistent } 0 -test interp-3.4 {testing interp exists and interp children} -body { - interp children a b c -} -returnCodes error -result {wrong # args: should be "interp children ?path?"} -test interp-3.5 {testing interp exists and interp children} -body { - interp exists a b c -} -returnCodes error -result {wrong # args: should be "interp exists ?path?"} -test interp-3.6 {testing interp exists and interp children} { +test interp-3.4 {testing interp exists and interp slaves} { + list [catch {interp slaves a b c} msg] $msg +} {1 {wrong # args: should be "interp slaves ?path?"}} +test interp-3.5 {testing interp exists and interp slaves} { + list [catch {interp exists a b c} msg] $msg +} {1 {wrong # args: should be "interp exists ?path?"}} +test interp-3.6 {testing interp exists and interp slaves} { interp exists } 1 -test interp-3.7 {testing interp exists and interp children} -setup { - catch {interp create a} -} -body { - interp children -} -result a -test interp-3.8 {testing interp exists and interp children} -body { - interp children a b c -} -returnCodes error -result {wrong # args: should be "interp children ?path?"} -test interp-3.9 {testing interp exists and interp children} -setup { - catch {interp create a} -} -body { +test interp-3.7 {testing interp exists and interp slaves} { + interp slaves +} a +test interp-3.8 {testing interp exists and interp slaves} { + list [catch {interp slaves a b c} msg] $msg +} {1 {wrong # args: should be "interp slaves ?path?"}} +test interp-3.9 {testing interp exists and interp slaves} { interp create {a a2} -safe - expr {"a2" in [interp children a]} -} -result 1 -test interp-3.10 {testing interp exists and interp children} -setup { - catch {interp create a} - catch {interp create {a a2}} -} -body { + expr {[lsearch [interp slaves a] a2] >= 0} +} 1 +test interp-3.10 {testing interp exists and interp slaves} { interp exists {a a2} -} -result 1 +} 1 # Part 3: Testing "interp delete" test interp-3.11 {testing interp delete} { @@ -173,12 +160,12 @@ test interp-4.1 {testing interp delete} { catch {interp create a} interp delete a } "" -test interp-4.2 {testing interp delete} -returnCodes error -body { - interp delete nonexistent -} -result {could not find interpreter "nonexistent"} -test interp-4.3 {testing interp delete} -returnCodes error -body { - interp delete x y z -} -result {could not find interpreter "x"} +test interp-4.2 {testing interp delete} { + list [catch {interp delete nonexistent} msg] $msg +} {1 {could not find interpreter "nonexistent"}} +test interp-4.3 {testing interp delete} { + list [catch {interp delete x y z} msg] $msg +} {1 {could not find interpreter "x"}} test interp-4.4 {testing interp delete} { interp delete } "" @@ -186,7 +173,7 @@ test interp-4.5 {testing interp delete} { interp create a interp create {a x1} interp delete {a x1} - expr {"x1" in [interp children a]} + expr {[lsearch [interp slaves a] x1] >= 0} } 0 test interp-4.6 {testing interp delete} { interp create c1 @@ -194,23 +181,23 @@ test interp-4.6 {testing interp delete} { interp create c3 interp delete c1 c2 c3 } "" -test interp-4.7 {testing interp delete} -returnCodes error -body { +test interp-4.7 {testing interp delete} { interp create c1 interp create c2 - interp delete c1 c2 c3 -} -result {could not find interpreter "c3"} -test interp-4.8 {testing interp delete} -returnCodes error -body { - interp delete {} -} -result {cannot delete the current interpreter} + list [catch {interp delete c1 c2 c3} msg] $msg +} {1 {could not find interpreter "c3"}} +test interp-4.8 {testing interp delete} { + list [catch {interp delete {}} msg] $msg +} {1 {cannot delete the current interpreter}} -foreach i [interp children] { +foreach i [interp slaves] { interp delete $i } # Part 4: Consistency checking - all nondeleted interpreters should be # there: test interp-5.1 {testing consistency} { - interp children + interp slaves } "" test interp-5.2 {testing consistency} { interp exists a @@ -224,83 +211,80 @@ interp create a # Part 5: Testing eval in interpreter object command and with interp command test interp-6.1 {testing eval} { - a eval expr {{3 + 5}} + a eval expr 3 + 5 } 8 -test interp-6.2 {testing eval} -returnCodes error -body { - a eval foo -} -result {invalid command name "foo"} +test interp-6.2 {testing eval} { + list [catch {a eval foo} msg] $msg +} {1 {invalid command name "foo"}} test interp-6.3 {testing eval} { - a eval {proc foo {} {expr {3 + 5}}} + a eval {proc foo {} {expr 3 + 5}} a eval foo } 8 -catch {a eval {proc foo {} {expr {3 + 5}}}} test interp-6.4 {testing eval} { interp eval a foo } 8 + test interp-6.5 {testing eval} { interp create {a x2} - interp eval {a x2} {proc frob {} {expr {4 * 9}}} + interp eval {a x2} {proc frob {} {expr 4 * 9}} interp eval {a x2} frob } 36 -catch {interp create {a x2}} -test interp-6.6 {testing eval} -returnCodes error -body { - interp eval {a x2} foo -} -result {invalid command name "foo"} - -# UTILITY PROCEDURE RUNNING IN PARENT INTERPRETER: -proc in_parent {args} { - return [list seen in parent: $args] +test interp-6.6 {testing eval} { + list [catch {interp eval {a x2} foo} msg] $msg +} {1 {invalid command name "foo"}} + +# UTILITY PROCEDURE RUNNING IN MASTER INTERPRETER: +proc in_master {args} { + return [list seen in master: $args] } # Part 6: Testing basic alias creation test interp-7.1 {testing basic alias creation} { - a alias foo in_parent + a alias foo in_master } foo -catch {a alias foo in_parent} test interp-7.2 {testing basic alias creation} { - a alias bar in_parent a1 a2 a3 + a alias bar in_master a1 a2 a3 } bar -catch {a alias bar in_parent a1 a2 a3} # Test 6.3 has been deleted. test interp-7.3 {testing basic alias creation} { a alias foo -} in_parent +} in_master test interp-7.4 {testing basic alias creation} { a alias bar -} {in_parent a1 a2 a3} +} {in_master a1 a2 a3} test interp-7.5 {testing basic alias creation} { lsort [a aliases] } {bar foo} -test interp-7.6 {testing basic aliases arg checking} -returnCodes error -body { - a aliases too many args -} -result {wrong # args: should be "a aliases"} +test interp-7.6 {testing basic aliases arg checking} { + list [catch {a aliases too many args} msg] $msg +} {1 {wrong # args: should be "a aliases"}} # Part 7: testing basic alias invocation test interp-8.1 {testing basic alias invocation} { catch {interp create a} - a alias foo in_parent + a alias foo in_master a eval foo s1 s2 s3 -} {seen in parent: {s1 s2 s3}} +} {seen in master: {s1 s2 s3}} test interp-8.2 {testing basic alias invocation} { catch {interp create a} - a alias bar in_parent a1 a2 a3 + a alias bar in_master a1 a2 a3 a eval bar s1 s2 s3 -} {seen in parent: {a1 a2 a3 s1 s2 s3}} -test interp-8.3 {testing basic alias invocation} -returnCodes error -body { +} {seen in master: {a1 a2 a3 s1 s2 s3}} +test interp-8.3 {testing basic alias invocation} { catch {interp create a} - a alias -} -result {wrong # args: should be "a alias aliasName ?targetName? ?arg ...?"} + list [catch {a alias} msg] $msg +} {1 {wrong # args: should be "a alias aliasName ?targetName? ?args..?"}} # Part 8: Testing aliases for non-existent or hidden targets test interp-9.1 {testing aliases for non-existent targets} { catch {interp create a} - a alias zop nonexistent-command-in-parent + a alias zop nonexistent-command-in-master list [catch {a eval zop} msg] $msg -} {1 {invalid command name "nonexistent-command-in-parent"}} +} {1 {invalid command name "nonexistent-command-in-master"}} test interp-9.2 {testing aliases for non-existent targets} { catch {interp create a} - a alias zop nonexistent-command-in-parent - proc nonexistent-command-in-parent {} {return i_exist!} + a alias zop nonexistent-command-in-master + proc nonexistent-command-in-master {} {return i_exist!} a eval zop } i_exist! test interp-9.3 {testing aliases for hidden commands} { @@ -329,8 +313,8 @@ test interp-9.4 {testing aliases and namespace commands} { set res } {GLOBAL GLOBAL} -if {[info command nonexistent-command-in-parent] != ""} { - rename nonexistent-command-in-parent {} +if {[info command nonexistent-command-in-master] != ""} { + rename nonexistent-command-in-master {} } # Part 9: Aliasing between interpreters @@ -380,9 +364,9 @@ test interp-10.6 {testing aliasing between interpreters} { interp create a interp create b interp alias a a_command b b_command a1 a2 a3 - b alias b_command in_parent b1 b2 b3 + b alias b_command in_master b1 b2 b3 a eval a_command m1 m2 m3 -} {seen in parent: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} +} {seen in master: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} test interp-10.7 {testing aliases between interpreters} { catch {interp delete a} interp create a @@ -447,78 +431,83 @@ test interp-11.7 {testing interp target} { test interp-12.1 {testing interp issafe} { interp issafe } 0 -test interp-12.2 {testing interp issafe} { +test interp-12.2 {testing interp issafe} -setup { catch {interp delete a} +} -body { interp create a interp issafe a -} 0 -test interp-12.3 {testing interp issafe} { +} -result 0 +test interp-12.3 {testing interp issafe} -setup { catch {interp delete a} +} -body { interp create a interp create {a x3} -safe interp issafe {a x3} -} 1 -test interp-12.4 {testing interp issafe} { +} -result 1 +test interp-12.4 {testing interp issafe} -setup { catch {interp delete a} +} -body { interp create a interp create {a x3} -safe interp create {a x3 foo} interp issafe {a x3 foo} -} 1 +} -result 1 # Part 12: testing interpreter object command "issafe" sub-command -test interp-13.1 {testing foo issafe} { +test interp-13.1 {testing foo issafe} -setup { catch {interp delete a} +} -body { interp create a a issafe -} 0 -test interp-13.2 {testing foo issafe} { +} -result 0 +test interp-13.2 {testing foo issafe} -setup { catch {interp delete a} +} -body { interp create a interp create {a x3} -safe a eval x3 issafe -} 1 -test interp-13.3 {testing foo issafe} { +} -result 1 +test interp-13.3 {testing foo issafe} -setup { catch {interp delete a} +} -body { interp create a interp create {a x3} -safe interp create {a x3 foo} a eval x3 eval foo issafe -} 1 -test interp-13.4 {testing issafe arg checking} { +} -result 1 +test interp-13.4 {testing issafe arg checking} -body { catch {interp create a} - list [catch {a issafe too many args} msg] $msg -} {1 {wrong # args: should be "a issafe"}} + a issafe too many args +} -returnCodes error -result {wrong # args: should be "a issafe"} # part 14: testing interp aliases -test interp-14.1 {testing interp aliases} -setup { - interp create abc -} -body { - interp eval abc {interp aliases} -} -cleanup { - interp delete abc -} -result "" -test interp-14.2 {testing interp aliases} { +test interp-14.1 {testing interp aliases} { + interp aliases +} "" +test interp-14.2 {testing interp aliases} -setup { catch {interp delete a} +} -body { interp create a a alias a1 puts a alias a2 puts a alias a3 puts lsort [interp aliases a] -} {a1 a2 a3} -test interp-14.3 {testing interp aliases} { +} -result {a1 a2 a3} +test interp-14.3 {testing interp aliases} -setup { catch {interp delete a} +} -body { interp create a interp create {a x3} interp alias {a x3} froboz "" puts interp aliases {a x3} -} froboz -test interp-14.4 {testing interp alias - alias over parent} { - # SF Bug 641195 +} -result froboz +test interp-14.4 {testing interp alias - alias over master} -setup { catch {interp delete a} +} -body { + # SF Bug 641195 interp create a list [catch {interp alias "" a a eval} msg] $msg [info commands a] -} {1 {cannot define or rename alias "a": interpreter deleted} {}} +} -result {1 {cannot define or rename alias "a": interpreter deleted} {}} test interp-14.5 {testing interp-alias: wrong # args} -body { proc setx x {set x} interp alias {} a {} setx @@ -606,18 +595,6 @@ test interp-14.10 {testing interp-alias: error messages} -setup { invoked from within "a 1"} -test interp-14.11 {{interp alias} {target named the empty string} {bug 2bf56185}} -setup { - set interp [interp create [info cmdcount]] - interp eval $interp { - proc {} args {return $args} - } - -} -body { - interp alias {} p1 $interp {} - p1 one two three -} -cleanup { - interp delete $interp -} -result {one two three} # part 15: testing file sharing test interp-15.1 {testing file sharing} { @@ -699,7 +676,8 @@ test interp-15.8 {testing file transferring} -body { # Torture tests for interpreter deletion order # proc kill {} {interp delete xxx} -test interp-16.0 {testing deletion order} { + +test interp-15.9 {testing deletion order} { catch {interp delete xxx} interp create xxx xxx alias kill kill @@ -746,7 +724,7 @@ test interp-16.5 {testing deletion order, bgerror} { xxx eval {proc bgerror {args} {exit}} xxx alias exit kill xxx proc kill {i} {interp delete $i} - xxx eval after 100 expr {a + b} + xxx eval after 100 expr a + b after 200 update interp exists xxx @@ -793,32 +771,32 @@ test interp-17.6 {alias loop prevention} { } {1 {cannot define or rename alias "b": would create a loop}} # -# Test robustness of Tcl_DeleteInterp when applied to a child interpreter. +# Test robustness of Tcl_DeleteInterp when applied to a slave interpreter. # If there are bugs in the implementation these tests are likely to expose # the bugs as a core dump. # -test interp-18.1 {testing Tcl_DeleteInterp vs children} testinterpdelete { +test interp-18.1 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { list [catch {testinterpdelete} msg] $msg } {1 {wrong # args: should be "testinterpdelete path"}} -test interp-18.2 {testing Tcl_DeleteInterp vs children} testinterpdelete { +test interp-18.2 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { catch {interp delete a} interp create a testinterpdelete a } "" -test interp-18.3 {testing Tcl_DeleteInterp vs children} testinterpdelete { +test interp-18.3 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { catch {interp delete a} interp create a interp create {a b} testinterpdelete {a b} } "" -test interp-18.4 {testing Tcl_DeleteInterp vs children} testinterpdelete { +test interp-18.4 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { catch {interp delete a} interp create a interp create {a b} testinterpdelete a } "" -test interp-18.5 {testing Tcl_DeleteInterp vs children} testinterpdelete { +test interp-18.5 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { catch {interp delete a} interp create a interp create {a b} @@ -826,7 +804,7 @@ test interp-18.5 {testing Tcl_DeleteInterp vs children} testinterpdelete { proc dodel {x} {testinterpdelete $x} list [catch {interp eval {a b} {dodel {a b}}} msg] $msg } {0 {}} -test interp-18.6 {testing Tcl_DeleteInterp vs children} testinterpdelete { +test interp-18.6 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { catch {interp delete a} interp create a interp create {a b} @@ -876,12 +854,12 @@ test interp-18.9 {eval in deleted interp, bug 495830} { interp create tst interp alias tst suicide {} interp delete tst list [catch {tst eval {suicide; set a 5}} msg] $msg -} {1 {attempt to call eval in deleted interpreter}} +} {1 {attempt to call eval in deleted interpreter}} test interp-18.10 {eval in deleted interp, bug 495830} { interp create tst interp alias tst suicide {} interp delete tst list [catch {tst eval {set set set; suicide; $set a 5}} msg] $msg -} {1 {attempt to call eval in deleted interpreter}} +} {1 {attempt to call eval in deleted interpreter}} # Test alias deletion @@ -966,12 +944,12 @@ test interp-19.9 {alias deletion, renaming} { interp create a interp alias a foo a bar interp eval a rename foo blotz - interp eval a {proc foo {} {expr {34 * 34}}} + interp eval a {proc foo {} {expr 34 * 34}} interp alias a foo {} set l [interp eval a foo] interp delete a set l -} 1156 +} 1156 test interp-20.1 {interp hide, interp expose and interp invokehidden} { set a [interp create] @@ -1192,7 +1170,7 @@ test interp-20.21 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg interp delete a set l @@ -1201,7 +1179,7 @@ test interp-20.22 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg interp delete a set l @@ -1210,7 +1188,7 @@ test interp-20.23 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a eval {interp hide {} list}} msg] + lappend l [catch {a eval {interp hide {} list}} msg] lappend l $msg interp delete a set l @@ -1220,7 +1198,7 @@ test interp-20.24 {interp hide vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {a eval {interp hide b list}} msg] + lappend l [catch {a eval {interp hide b list}} msg] lappend l $msg interp delete a set l @@ -1239,7 +1217,7 @@ test interp-20.26 {interp expoose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg lappend l [catch {a expose list} msg] lappend l $msg @@ -1250,9 +1228,9 @@ test interp-20.27 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg - lappend l [catch {interp expose a list} msg] + lappend l [catch {interp expose a list} msg] lappend l $msg interp delete a set l @@ -1261,7 +1239,7 @@ test interp-20.28 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg lappend l [catch {a eval {interp expose {} list}} msg] lappend l $msg @@ -1272,9 +1250,9 @@ test interp-20.29 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg - lappend l [catch {a eval {interp expose {} list}} msg] + lappend l [catch {a eval {interp expose {} list}} msg] lappend l $msg interp delete a set l @@ -1284,9 +1262,9 @@ test interp-20.30 {interp expose vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {interp hide {a b} list} msg] + lappend l [catch {interp hide {a b} list} msg] lappend l $msg - lappend l [catch {a eval {interp expose b list}} msg] + lappend l [catch {a eval {interp expose b list}} msg] lappend l $msg interp delete a set l @@ -1296,7 +1274,7 @@ test interp-20.31 {interp expose vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {interp hide {a b} list} msg] + lappend l [catch {interp hide {a b} list} msg] lappend l $msg lappend l [catch {interp expose {a b} list} msg] lappend l $msg @@ -1615,36 +1593,15 @@ test interp-20.49 {interp invokehidden -namespace} -setup { set script [makeFile { set x [namespace current] } script] - interp create -safe child + interp create -safe slave } -body { - child invokehidden -namespace ::foo source $script - child eval {set ::foo::x} + slave invokehidden -namespace ::foo source $script + slave eval {set ::foo::x} } -cleanup { - interp delete child + interp delete slave removeFile script } -result ::foo -test interp-20.50 {Bug 2486550} -setup { - interp create child -} -body { - child hide coroutine - child invokehidden coroutine -} -cleanup { - interp delete child -} -returnCodes error -match glob -result * -test interp-20.50.1 {Bug 2486550} -setup { - interp create child -} -body { - child hide coroutine - catch {child invokehidden coroutine} m o - dict get $o -errorinfo -} -cleanup { - unset -nocomplain m 0 - interp delete child -} -result {wrong # args: should be "coroutine name cmd ?arg ...?" - while executing -"coroutine" - invoked from within -"child invokehidden coroutine"} + test interp-21.1 {interp hidden} { interp hidden {} @@ -1652,73 +1609,67 @@ test interp-21.1 {interp hidden} { test interp-21.2 {interp hidden} { interp hidden } "" -test interp-21.3 {interp hidden vs interp hide, interp expose} -setup { +test interp-21.3 {interp hidden vs interp hide, interp expose} { set l "" -} -body { lappend l [interp hidden] interp hide {} pwd lappend l [interp hidden] interp expose {} pwd lappend l [interp hidden] -} -result {{} pwd {}} -test interp-21.4 {interp hidden} -setup { + set l +} {{} pwd {}} +test interp-21.4 {interp hidden} { catch {interp delete a} -} -body { interp create a - interp hidden a -} -cleanup { + set l [interp hidden a] interp delete a -} -result "" -test interp-21.5 {interp hidden} -setup { + set l +} "" +test interp-21.5 {interp hidden} { catch {interp delete a} -} -body { interp create -safe a - lsort [interp hidden a] -} -cleanup { + set l [lsort [interp hidden a]] interp delete a -} -result $hidden_cmds -test interp-21.6 {interp hidden vs interp hide, interp expose} -setup { + set l +} $hidden_cmds +test interp-21.6 {interp hidden vs interp hide, interp expose} { catch {interp delete a} - set l "" -} -body { interp create a + set l "" lappend l [interp hidden a] interp hide a pwd lappend l [interp hidden a] interp expose a pwd lappend l [interp hidden a] -} -cleanup { interp delete a -} -result {{} pwd {}} -test interp-21.7 {interp hidden} -setup { + set l +} {{} pwd {}} +test interp-21.7 {interp hidden} { catch {interp delete a} -} -body { interp create a - a hidden -} -cleanup { + set l [a hidden] interp delete a -} -result "" -test interp-21.8 {interp hidden} -setup { + set l +} "" +test interp-21.8 {interp hidden} { catch {interp delete a} -} -body { interp create a -safe - lsort [a hidden] -} -cleanup { + set l [lsort [a hidden]] interp delete a -} -result $hidden_cmds -test interp-21.9 {interp hidden vs interp hide, interp expose} -setup { + set l +} $hidden_cmds +test interp-21.9 {interp hidden vs interp hide, interp expose} { catch {interp delete a} - set l "" -} -body { interp create a + set l "" lappend l [a hidden] a hide pwd lappend l [a hidden] a expose pwd lappend l [a hidden] -} -cleanup { interp delete a -} -result {{} pwd {}} + set l +} {{} pwd {}} test interp-22.1 {testing interp marktrusted} { catch {interp delete a} @@ -1818,161 +1769,183 @@ test interp-22.9 {testing interp marktrusted} { set l } {1 1 1 0 0} -test interp-23.1 {testing hiding vs aliases: unsafe interp} -setup { +test interp-23.1 {testing hiding vs aliases} { catch {interp delete a} - set l "" -} -body { interp create a + set l "" lappend l [interp hidden a] a alias bar bar - lappend l [interp aliases a] [interp hidden a] + lappend l [interp aliases a] + lappend l [interp hidden a] a hide bar - lappend l [interp aliases a] [interp hidden a] + lappend l [interp aliases a] + lappend l [interp hidden a] a alias bar {} - lappend l [interp aliases a] [interp hidden a] -} -cleanup { + lappend l [interp aliases a] + lappend l [interp hidden a] interp delete a -} -result {{} bar {} bar bar {} {}} -test interp-23.2 {testing hiding vs aliases: safe interp} -setup { + set l +} {{} bar {} bar bar {} {}} +test interp-23.2 {testing hiding vs aliases} {unixOrPc} { catch {interp delete a} - set l "" -} -constraints {unixOrWin} -body { interp create a -safe + set l "" lappend l [lsort [interp hidden a]] a alias bar bar - lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] + lappend l [lsort [interp aliases a]] + lappend l [lsort [interp hidden a]] a hide bar - lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] + lappend l [lsort [interp aliases a]] + lappend l [lsort [interp hidden a]] a alias bar {} - lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] -} -cleanup { + lappend l [lsort [interp aliases a]] + lappend l [lsort [interp hidden a]] interp delete a -} -result [list $hidden_cmds {bar clock} $hidden_cmds {bar clock} [lsort [concat $hidden_cmds bar]] {clock} $hidden_cmds] + set l +} {{cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {bar cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload}} -test interp-24.1 {result resetting on error} -setup { +test interp-24.1 {result resetting on error} { catch {interp delete a} -} -body { interp create a - interp alias a foo {} apply {args {error $args}} - interp eval a { - lappend l [catch {foo 1 2 3} msg] $msg - lappend l [catch {foo 3 4 5} msg] $msg - } -} -cleanup { + proc foo args {error $args} + interp alias a foo {} foo + set l [interp eval a { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] interp delete a -} -result {1 {1 2 3} 1 {3 4 5}} -test interp-24.2 {result resetting on error} -setup { + rename foo {} + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.2 {result resetting on error} { catch {interp delete a} -} -body { interp create a -safe - interp alias a foo {} apply {args {error $args}} - interp eval a { - lappend l [catch {foo 1 2 3} msg] $msg - lappend l [catch {foo 3 4 5} msg] $msg - } -} -cleanup { + proc foo args {error $args} + interp alias a foo {} foo + set l [interp eval a { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] interp delete a -} -result {1 {1 2 3} 1 {3 4 5}} -test interp-24.3 {result resetting on error} -setup { + rename foo {} + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.3 {result resetting on error} { catch {interp delete a} -} -body { interp create a interp create {a b} interp eval a { proc foo args {error $args} } interp alias {a b} foo a foo - interp eval {a b} { - lappend l [catch {foo 1 2 3} msg] $msg - lappend l [catch {foo 3 4 5} msg] $msg - } -} -cleanup { + set l [interp eval {a b} { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] interp delete a -} -result {1 {1 2 3} 1 {3 4 5}} -test interp-24.4 {result resetting on error} -setup { + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.4 {result resetting on error} { catch {interp delete a} -} -body { interp create a -safe interp create {a b} interp eval a { proc foo args {error $args} } interp alias {a b} foo a foo - interp eval {a b} { + set l [interp eval {a b} { + set l {} lappend l [catch {foo 1 2 3} msg] lappend l $msg lappend l [catch {foo 3 4 5} msg] lappend l $msg - } -} -cleanup { + set l + }] interp delete a -} -result {1 {1 2 3} 1 {3 4 5}} -test interp-24.5 {result resetting on error} -setup { + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.5 {result resetting on error} { catch {interp delete a} catch {interp delete b} -} -body { interp create a interp create b interp eval a { proc foo args {error $args} } interp alias b foo a foo - interp eval b { - lappend l [catch {foo 1 2 3} msg] $msg - lappend l [catch {foo 3 4 5} msg] $msg - } -} -cleanup { + set l [interp eval b { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] interp delete a - interp delete b -} -result {1 {1 2 3} 1 {3 4 5}} -test interp-24.6 {result resetting on error} -setup { + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.6 {result resetting on error} { catch {interp delete a} catch {interp delete b} -} -body { interp create a -safe interp create b -safe interp eval a { proc foo args {error $args} } interp alias b foo a foo - interp eval b { - lappend l [catch {foo 1 2 3} msg] $msg - lappend l [catch {foo 3 4 5} msg] $msg - } -} -cleanup { + set l [interp eval b { + set l {} + lappend l [catch {foo 1 2 3} msg] + lappend l $msg + lappend l [catch {foo 3 4 5} msg] + lappend l $msg + set l + }] interp delete a - interp delete b -} -result {1 {1 2 3} 1 {3 4 5}} -test interp-24.7 {result resetting on error} -setup { + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.7 {result resetting on error} { catch {interp delete a} - set l {} -} -body { interp create a interp eval a { proc foo args {error $args} } - lappend l [catch {interp eval a foo 1 2 3} msg] $msg - lappend l [catch {interp eval a foo 3 4 5} msg] $msg -} -cleanup { + set l {} + lappend l [catch {interp eval a foo 1 2 3} msg] + lappend l $msg + lappend l [catch {interp eval a foo 3 4 5} msg] + lappend l $msg interp delete a -} -result {1 {1 2 3} 1 {3 4 5}} -test interp-24.8 {result resetting on error} -setup { + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.8 {result resetting on error} { catch {interp delete a} - set l {} -} -body { interp create a -safe interp eval a { proc foo args {error $args} } - lappend l [catch {interp eval a foo 1 2 3} msg] $msg - lappend l [catch {interp eval a foo 3 4 5} msg] $msg -} -cleanup { + set l {} + lappend l [catch {interp eval a foo 1 2 3} msg] + lappend l $msg + lappend l [catch {interp eval a foo 3 4 5} msg] + lappend l $msg interp delete a -} -result {1 {1 2 3} 1 {3 4 5}} -test interp-24.9 {result resetting on error} -setup { + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.9 {result resetting on error} { catch {interp delete a} - set l {} -} -body { interp create a interp create {a b} interp eval {a b} { @@ -1983,15 +1956,16 @@ test interp-24.9 {result resetting on error} -setup { eval interp eval b foo $args } } - lappend l [catch {interp eval a foo 1 2 3} msg] $msg - lappend l [catch {interp eval a foo 3 4 5} msg] $msg -} -cleanup { + set l {} + lappend l [catch {interp eval a foo 1 2 3} msg] + lappend l $msg + lappend l [catch {interp eval a foo 3 4 5} msg] + lappend l $msg interp delete a -} -result {1 {1 2 3} 1 {3 4 5}} -test interp-24.10 {result resetting on error} -setup { + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.10 {result resetting on error} { catch {interp delete a} - set l {} -} -body { interp create a -safe interp create {a b} interp eval {a b} { @@ -2002,14 +1976,16 @@ test interp-24.10 {result resetting on error} -setup { eval interp eval b foo $args } } - lappend l [catch {interp eval a foo 1 2 3} msg] $msg - lappend l [catch {interp eval a foo 3 4 5} msg] $msg -} -cleanup { + set l {} + lappend l [catch {interp eval a foo 1 2 3} msg] + lappend l $msg + lappend l [catch {interp eval a foo 3 4 5} msg] + lappend l $msg interp delete a -} -result {1 {1 2 3} 1 {3 4 5}} -test interp-24.11 {result resetting on error} -setup { + set l +} {1 {1 2 3} 1 {3 4 5}} +test interp-24.11 {result resetting on error} { catch {interp delete a} -} -body { interp create a interp create {a b} interp eval {a b} { @@ -2017,17 +1993,20 @@ test interp-24.11 {result resetting on error} -setup { } interp eval a { proc foo args { - lappend l [catch {eval interp eval b foo $args} msg] $msg - lappend l [catch {eval interp eval b foo $args} msg] $msg + set l {} + lappend l [catch {eval interp eval b foo $args} msg] + lappend l $msg + lappend l [catch {eval interp eval b foo $args} msg] + lappend l $msg + set l } } - interp eval a foo 1 2 3 -} -cleanup { + set l [interp eval a foo 1 2 3] interp delete a -} -result {1 {1 2 3} 1 {1 2 3}} -test interp-24.12 {result resetting on error} -setup { + set l +} {1 {1 2 3} 1 {1 2 3}} +test interp-24.12 {result resetting on error} { catch {interp delete a} -} -body { interp create a -safe interp create {a b} interp eval {a b} { @@ -2035,22 +2014,28 @@ test interp-24.12 {result resetting on error} -setup { } interp eval a { proc foo args { - lappend l [catch {eval interp eval b foo $args} msg] $msg - lappend l [catch {eval interp eval b foo $args} msg] $msg + set l {} + lappend l [catch {eval interp eval b foo $args} msg] + lappend l $msg + lappend l [catch {eval interp eval b foo $args} msg] + lappend l $msg + set l } } - interp eval a foo 1 2 3 -} -cleanup { + set l [interp eval a foo 1 2 3] interp delete a -} -result {1 {1 2 3} 1 {1 2 3}} + set l +} {1 {1 2 3} 1 {1 2 3}} + +unset hidden_cmds -test interp-25.1 {testing aliasing of string commands} -setup { +test interp-25.1 {testing aliasing of string commands} { catch {interp delete a} -} -body { interp create a a alias exec foo ;# Relies on exec being a string command! interp delete a -} -result "" +} "" + # # Interps result transmission @@ -2058,8 +2043,9 @@ test interp-25.1 {testing aliasing of string commands} -setup { test interp-26.1 {result code transmission : interp eval direct} { # Test that all the possibles error codes from Tcl get passed up - # from the child interp's context to the parent, even though the - # child nominally thinks the command is running at the root level. + # 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 {} @@ -2070,6 +2056,8 @@ test interp-26.1 {result code transmission : interp eval direct} { 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} @@ -2083,10 +2071,12 @@ test interp-26.2 {result code transmission : interp eval indirect} { 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 - # child interp's context to the parent, even though the child nominally - # thinks the command is running at the root level. + # 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 {} @@ -2100,6 +2090,7 @@ test interp-26.3 {result code transmission : aliases} { 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 @@ -2113,35 +2104,36 @@ test interp-26.4 {result code transmission: invoke hidden direct--bug 1637} \ interp delete a set res } {-1 0 1 2 3 4 5} -test interp-26.5 {result code transmission: invoke hidden indirect--bug 1637} -setup { + +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 -} -body { - # The known bug is that the break and continue should raise errors that - # they are used outside a loop. 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 } - return $res -} -cleanup { interp delete a -} -result {-1 ret-1 0 ret0 1 ret1 2 ret2 3 ret3 4 ret4 5 ret5} -test interp-26.6 {result code transmission: all combined--bug 1637} -setup { - set interp [interp create] -} -constraints knownBug -body { - # Test that all the possibles error codes from Tcl get passed in both - # directions. This doesn't work. + 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 - lappend aliasTrace $args + global aliasTrace; + lappend aliasTrace $args; interp invokehidden $interp {*}$args } foreach c {return} { - interp hide $interp $c - interp alias $interp $c {} MyTestAlias $interp $c + interp hide $interp $c; + interp alias $interp $c {} MyTestAlias $interp $c; } interp eval $interp {proc ret {code} {return -code $code ret$code}} set res {} @@ -2149,247 +2141,248 @@ test interp-26.6 {result code transmission: all combined--bug 1637} -setup { for {set code -1} {$code<=5} {incr code} { lappend res [catch {interp eval $interp ret $code} msg] $msg } - return $res -} -cleanup { - interp delete $interp -} -result {-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. + interp delete $interp; + 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.7 {errorInfo transmission: regular interps} -setup { - set interp [interp create] -} -body { + +test interp-26.7 {errorInfo transmission: regular interps} { + set interp [interp create]; proc MyError {secret} { return -code error "msg" } proc MyTestAlias {interp args} { MyError "some secret" } - interp alias $interp test {} MyTestAlias $interp - interp eval $interp {catch test;set ::errorInfo} -} -cleanup { - interp delete $interp -} -result {msg + interp alias $interp test {} MyTestAlias $interp; + set res [interp eval $interp {catch test;set ::errorInfo}] + interp delete $interp; + set res +} {msg while executing "MyError "some secret"" (procedure "MyTestAlias" line 2) invoked from within "test"} -test interp-26.8 {errorInfo transmission: safe interps--bug 1637} -setup { - set interp [interp create -safe] -} -constraints knownBug -body { - # this test fails because the errorInfo is fully transmitted whether the - # interp is safe or not. The errorInfo should never report data from the - # parent interpreter because it could contain sensitive information. + +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. 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" } proc MyTestAlias {interp args} { MyError "some secret" } - interp alias $interp test {} MyTestAlias $interp - interp eval $interp {catch test;set ::errorInfo} -} -cleanup { - interp delete $interp -} -result {msg + interp alias $interp test {} MyTestAlias $interp; + set res [interp eval $interp {catch test;set ::errorInfo}] + interp delete $interp; + set res +} {msg while executing "test"} # Interps & Namespaces -test interp-27.1 {interp aliases & namespaces} -setup { - set i [interp create] -} -body { - set aliasTrace {} - proc tstAlias {args} { - global aliasTrace - lappend aliasTrace [list [namespace current] $args] - } - $i alias foo::bar tstAlias foo::bar +test interp-27.1 {interp aliases & namespaces} { + set i [interp create]; + set aliasTrace {}; + proc tstAlias {args} { + global aliasTrace; + lappend aliasTrace [list [namespace current] $args]; + } + $i alias foo::bar tstAlias foo::bar; $i eval foo::bar test - return $aliasTrace -} -cleanup { interp delete $i -} -result {{:: {foo::bar test}}} -test interp-27.2 {interp aliases & namespaces} -setup { - set i [interp create] -} -body { - set aliasTrace {} - proc tstAlias {args} { - global aliasTrace - lappend aliasTrace [list [namespace current] $args] - } - $i alias foo::bar tstAlias foo::bar + set aliasTrace; +} {{:: {foo::bar test}}} + +test interp-27.2 {interp aliases & namespaces} { + set i [interp create]; + set aliasTrace {}; + proc tstAlias {args} { + global aliasTrace; + lappend aliasTrace [list [namespace current] $args]; + } + $i alias foo::bar tstAlias foo::bar; $i eval namespace eval foo {bar test} - return $aliasTrace -} -cleanup { interp delete $i -} -result {{:: {foo::bar test}}} -test interp-27.3 {interp aliases & namespaces} -setup { - set i [interp create] -} -body { - set aliasTrace {} - proc tstAlias {args} { - global aliasTrace - lappend aliasTrace [list [namespace current] $args] + set aliasTrace; +} {{:: {foo::bar test}}} + +test interp-27.3 {interp aliases & namespaces} { + set i [interp create]; + set aliasTrace {}; + proc tstAlias {args} { + global aliasTrace; + lappend aliasTrace [list [namespace current] $args]; } interp eval $i {namespace eval foo {proc bar {} {error "bar called"}}} - interp alias $i foo::bar {} tstAlias foo::bar + interp alias $i foo::bar {} tstAlias foo::bar; interp eval $i {namespace eval foo {bar test}} - return $aliasTrace -} -cleanup { interp delete $i -} -result {{:: {foo::bar test}}} -test interp-27.4 {interp aliases & namespaces} -setup { - set i [interp create] -} -body { + set aliasTrace; +} {{:: {foo::bar test}}} + +test interp-27.4 {interp aliases & namespaces} { + set i [interp create]; namespace eval foo2 { - variable aliasTrace {} - proc bar {args} { - variable aliasTrace - lappend aliasTrace [list [namespace current] $args] + variable aliasTrace {}; + proc bar {args} { + variable aliasTrace; + lappend aliasTrace [list [namespace current] $args]; } } - $i alias foo::bar foo2::bar foo::bar + $i alias foo::bar foo2::bar foo::bar; $i eval namespace eval foo {bar test} - return $foo2::aliasTrace -} -cleanup { - namespace delete foo2 - interp delete $i -} -result {{::foo2 {foo::bar test}}} -test interp-27.5 {interp hidden & namespaces} -setup { - set i [interp create] -} -constraints knownBug -body { - interp eval $i { - namespace eval foo { - proc bar {args} { - return "bar called ([namespace current]) ($args)" - } - } - } - set res [list [interp eval $i {namespace eval foo {bar test1}}]] - interp hide $i foo::bar - lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg] -} -cleanup { - interp delete $i -} -result {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}} -test interp-27.6 {interp hidden & aliases & namespaces} -setup { - set i [interp create] -} -constraints knownBug -body { - set v root-parent - namespace eval foo { - variable v foo-parent - proc bar {interp args} { - variable v - list "parent bar called ($v) ([namespace current]) ($args)"\ - [interp invokehidden $interp foo::bar $args] - } - } - interp eval $i { - namespace eval foo { - namespace export * - variable v foo-child - proc bar {args} { - variable v - return "child bar called ($v) ([namespace current]) ($args)" - } - } - } - set res [list [interp eval $i {namespace eval foo {bar test1}}]] - $i hide foo::bar - $i alias foo::bar foo::bar $i - set res [concat $res [interp eval $i { - set v root-child - namespace eval test { - variable v foo-test - namespace import ::foo::* - bar test2 - } - }]] -} -cleanup { - namespace delete foo - interp delete $i -} -result {{child bar called (foo-child) (::foo) (test1)} {parent bar called (foo-parent) (::foo) (test2)} {child bar called (foo-child) (::foo) (test2)}} -test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup { - set i [interp create] -} -constraints knownBug -body { - set v root-parent - namespace eval mfoo { - variable v foo-parent - proc bar {interp args} { - variable v - list "parent bar called ($v) ([namespace current]) ($args)"\ - [interp invokehidden $interp test::bar $args] - } - } - interp eval $i { - namespace eval foo { - namespace export * - variable v foo-child - proc bar {args} { - variable v - return "child bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" - } - } - set v root-child - namespace eval test { - variable v foo-test - namespace import ::foo::* - } - } - set res [list [interp eval $i {namespace eval test {bar test1}}]] - $i hide test::bar - $i alias test::bar mfoo::bar $i - set res [concat $res [interp eval $i {test::bar test2}]] -} -cleanup { - namespace delete mfoo - interp delete $i -} -result {{child bar called (foo-child) (bar test1) (::tcltest) (::foo) (test1)} {parent bar called (foo-parent) (::mfoo) (test2)} {child bar called (foo-child) (test::bar test2) (::) (::foo) (test2)}} -test interp-27.8 {hiding, namespaces and integrity} knownBug { - namespace eval foo { - variable v 3 - proc bar {} {variable v; set v} - # next command would currently generate an unknown command "bar" error. - interp hide {} bar - } - namespace delete foo - list [catch {interp invokehidden {} foo::bar} msg] $msg -} {1 {invalid hidden command name "foo"}} - -test interp-28.1 {getting fooled by child's namespace ?} -setup { - set i [interp create -safe] - proc parent {interp args} {interp hide $interp list} -} -body { - $i alias parent parent $i + set r $foo2::aliasTrace; + namespace delete foo2; + set r +} {{::foo2 {foo::bar test}}} + +# the following tests are commented out while we don't support +# hiding in namespaces + +# test interp-27.5 {interp hidden & namespaces} { +# set i [interp create]; +# interp eval $i { +# namespace eval foo { +# proc bar {args} { +# return "bar called ([namespace current]) ($args)" +# } +# } +# } +# set res [list [interp eval $i {namespace eval foo {bar test1}}]] +# interp hide $i foo::bar; +# lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg] +# interp delete $i; +# set res; +#} {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}} + +# test interp-27.6 {interp hidden & aliases & namespaces} { +# set i [interp create]; +# set v root-master; +# namespace eval foo { +# variable v foo-master; +# proc bar {interp args} { +# variable v; +# list "master bar called ($v) ([namespace current]) ($args)"\ +# [interp invokehidden $interp foo::bar $args]; +# } +# } +# interp eval $i { +# namespace eval foo { +# namespace export * +# variable v foo-slave; +# proc bar {args} { +# variable v; +# return "slave bar called ($v) ([namespace current]) ($args)" +# } +# } +# } +# set res [list [interp eval $i {namespace eval foo {bar test1}}]] +# $i hide foo::bar; +# $i alias foo::bar foo::bar $i; +# set res [concat $res [interp eval $i { +# set v root-slave; +# namespace eval test { +# variable v foo-test; +# namespace import ::foo::*; +# bar test2 +# } +# }]] +# namespace delete foo; +# interp delete $i; +# set res +# } {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}} + + +# test interp-27.7 {interp hidden & aliases & imports & namespaces} { +# set i [interp create]; +# set v root-master; +# namespace eval mfoo { +# variable v foo-master; +# proc bar {interp args} { +# variable v; +# list "master bar called ($v) ([namespace current]) ($args)"\ +# [interp invokehidden $interp test::bar $args]; +# } +# } +# interp eval $i { +# namespace eval foo { +# namespace export * +# variable v foo-slave; +# proc bar {args} { +# variable v; +# return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" +# } +# } +# set v root-slave; +# namespace eval test { +# variable v foo-test; +# namespace import ::foo::*; +# } +# } +# set res [list [interp eval $i {namespace eval test {bar test1}}]] +# $i hide test::bar; +# $i alias test::bar mfoo::bar $i; +# set res [concat $res [interp eval $i {test::bar test2}]]; +# namespace delete mfoo; +# interp delete $i; +# set res +# } {{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 { +# variable v 3; +# proc bar {} {variable v; set v} +# # next command would currently generate an unknown command "bar" error. +# interp hide {} bar; +# } +# namespace delete foo; +# list [catch {interp invokehidden {} foo} msg] $msg; +#} {1 {invalid hidden command name "foo"}} + + +test interp-28.1 {getting fooled by slave's namespace ?} { + set i [interp create -safe]; + proc master {interp args} {interp hide $interp list} + $i alias master master $i; set r [interp eval $i { namespace eval foo { proc list {args} { - return "dummy foo::list" + return "dummy foo::list"; } - parent + master; } info commands list }] -} -cleanup { - rename parent {} - interp delete $i -} -result {} -test interp-28.2 {parent's nsName cache should not cross} -setup { + interp delete $i; + set r +} {} + +test interp-28.2 {master's nsName cache should not cross} { set i [interp create] - $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}} -} -body { - $i eval { + set res [$i eval { set x {namespace children ::} set y [list namespace children ::] - namespace delete {*}[filter [{*}$y]] + namespace delete [{*}$y] set j [interp create] - $j alias filter filter - $j eval {namespace delete {*}[filter [namespace children ::]]} + $j eval {namespace delete {*}[namespace children ::]} namespace eval foo {} - list [filter [eval $x]] [filter [eval $y]] [filter [$j eval $x]] [filter [$j eval $y]] - } -} -cleanup { + set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]] + interp delete $j + set res + }] interp delete $i -} -result {::foo ::foo {} {}} + set res +} {::foo ::foo {} {}} # Part 29: recursion limit # 29.1.* Argument checking @@ -2402,81 +2395,96 @@ test interp-28.2 {parent's nsName cache should not cross} -setup { test interp-29.1.1 {interp recursionlimit argument checking} { list [catch {interp recursionlimit} msg] $msg } {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}} + test interp-29.1.2 {interp recursionlimit argument checking} { list [catch {interp recursionlimit foo bar} msg] $msg } {1 {could not find interpreter "foo"}} + test interp-29.1.3 {interp recursionlimit argument checking} { list [catch {interp recursionlimit foo bar baz} msg] $msg } {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}} + test interp-29.1.4 {interp recursionlimit argument checking} { interp create moo set result [catch {interp recursionlimit moo bar} msg] interp delete moo list $result $msg } {1 {expected integer but got "bar"}} + test interp-29.1.5 {interp recursionlimit argument checking} { interp create moo set result [catch {interp recursionlimit moo 0} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} + test interp-29.1.6 {interp recursionlimit argument checking} { interp create moo set result [catch {interp recursionlimit moo -1} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} + test interp-29.1.7 {interp recursionlimit argument checking} { interp create moo set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg] interp delete moo list $result [string range $msg 0 35] } {1 {integer value too large to represent}} -test interp-29.1.8 {child recursionlimit argument checking} { + +test interp-29.1.8 {slave recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit foo bar} msg] interp delete moo list $result $msg } {1 {wrong # args: should be "moo recursionlimit ?newlimit?"}} -test interp-29.1.9 {child recursionlimit argument checking} { + +test interp-29.1.9 {slave recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit foo} msg] interp delete moo list $result $msg } {1 {expected integer but got "foo"}} -test interp-29.1.10 {child recursionlimit argument checking} { + +test interp-29.1.10 {slave recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit 0} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} -test interp-29.1.11 {child recursionlimit argument checking} { + +test interp-29.1.11 {slave recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit -1} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} -test interp-29.1.12 {child recursionlimit argument checking} { + +test interp-29.1.12 {slave recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg] interp delete moo list $result [string range $msg 0 35] } {1 {integer value too large to represent}} + test interp-29.2.1 {query recursion limit} { interp recursionlimit {} } 1000 + test interp-29.2.2 {query recursion limit} { set i [interp create] set n [interp recursionlimit $i] interp delete $i set n } 1000 + test interp-29.2.3 {query recursion limit} { set i [interp create] set n [$i recursionlimit] interp delete $i set n } 1000 + test interp-29.2.4 {query recursion limit} { set i [interp create] set r [$i eval { @@ -2487,6 +2495,7 @@ test interp-29.2.4 {query recursion limit} { interp delete $i set r } {42 42} + test interp-29.2.5 {query recursion limit} { set i [interp create] set n1 [interp recursionlimit $i 42] @@ -2494,6 +2503,7 @@ test interp-29.2.5 {query recursion limit} { interp delete $i list $n1 $n2 } {42 42} + test interp-29.2.6 {query recursion limit} { set i [interp create] set n1 [interp recursionlimit $i 42] @@ -2501,6 +2511,7 @@ test interp-29.2.6 {query recursion limit} { interp delete $i list $n1 $n2 } {42 42} + test interp-29.2.7 {query recursion limit} { set i [interp create] set n1 [$i recursionlimit 42] @@ -2508,6 +2519,7 @@ test interp-29.2.7 {query recursion limit} { interp delete $i list $n1 $n2 } {42 42} + test interp-29.2.8 {query recursion limit} { set i [interp create] set n1 [$i recursionlimit 42] @@ -2515,6 +2527,7 @@ test interp-29.2.8 {query recursion limit} { interp delete $i list $n1 $n2 } {42 42} + test interp-29.3.1 {recursion limit} { set i [interp create] set r [interp eval $i { @@ -2525,7 +2538,8 @@ test interp-29.3.1 {recursion limit} { }] interp delete $i set r -} {1 {too many nested evaluations (infinite loop?)} 49} +} {1 {too many nested evaluations (infinite loop?)} 48} + test interp-29.3.2 {recursion limit} { set i [interp create] interp recursionlimit $i 50 @@ -2536,7 +2550,8 @@ test interp-29.3.2 {recursion limit} { }] interp delete $i set r -} {1 {too many nested evaluations (infinite loop?)} 49} +} {1 {too many nested evaluations (infinite loop?)} 48} + test interp-29.3.3 {recursion limit} { set i [interp create] $i recursionlimit 50 @@ -2547,10 +2562,11 @@ test interp-29.3.3 {recursion limit} { }] interp delete $i set r -} {1 {too many nested evaluations (infinite loop?)} 49} +} {1 {too many nested evaluations (infinite loop?)} 48} + test interp-29.3.4 {recursion limit error reporting} { - interp create child - set r1 [child eval { + interp create slave + set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2564,13 +2580,14 @@ test interp-29.3.4 {recursion limit error reporting} { } } msg }] - set r2 [child eval { set msg }] - interp delete child + set r2 [slave eval { set msg }] + interp delete slave list $r1 $r2 } {1 {falling back due to new recursion limit}} + test interp-29.3.5 {recursion limit error reporting} { - interp create child - set r1 [child eval { + interp create slave + set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2584,13 +2601,14 @@ test interp-29.3.5 {recursion limit error reporting} { } } msg }] - set r2 [child eval { set msg }] - interp delete child + set r2 [slave eval { set msg }] + interp delete slave list $r1 $r2 } {1 {falling back due to new recursion limit}} + test interp-29.3.6 {recursion limit error reporting} { - interp create child - set r1 [child eval { + interp create slave + set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2604,166 +2622,59 @@ test interp-29.3.6 {recursion limit error reporting} { } } msg }] - set r2 [child eval { set msg }] - interp delete child - list $r1 $r2 -} {0 ok} -# -# Note that TEBC does not verify the interp's nesting level itself; the nesting -# level will only be verified when it invokes a non-bcc'd command. -# -test interp-29.3.7a {recursion limit error reporting} { - interp create child - after 0 {interp recursionlimit child 5} - set r1 [child eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - eval { # 5 - update - set x ok - } - } - } - } - } msg - }] - set r2 [child eval { set msg }] - interp delete child - list $r1 $r2 -} {0 ok} -test interp-29.3.7b {recursion limit error reporting} { - interp create child - after 0 {interp recursionlimit child 5} - set r1 [child eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - update - eval { # 5 - set x ok - } - } - } - } - } msg - }] - set r2 [child eval { set msg }] - interp delete child + set r2 [slave eval { set msg }] + interp delete slave list $r1 $r2 } {0 ok} -test interp-29.3.7c {recursion limit error reporting} { - interp create child - after 0 {interp recursionlimit child 5} - set r1 [child eval { + +test interp-29.3.7 {recursion limit error reporting} { + interp create slave + after 0 {interp recursionlimit slave 5} + set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 - update - set set set - $set x ok + update + set x ok } } } } } msg }] - set r2 [child eval { set msg }] - interp delete child + set r2 [slave eval { set msg }] + interp delete slave list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} -test interp-29.3.8a {recursion limit error reporting} { - interp create child - after 0 {interp recursionlimit child 4} - set r1 [child eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - eval { # 5 - update - set x ok - } - } - } - } - } msg - }] - set r2 [child eval { set msg }] - interp delete child - list $r1 $r2 -} {0 ok} -test interp-29.3.8b {recursion limit error reporting} { - interp create child - after 0 {interp recursionlimit child 4} - set r1 [child eval { + +test interp-29.3.8 {recursion limit error reporting} { + interp create slave + after 0 {interp recursionlimit slave 4} + set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 - update eval { # 5 - set x ok + update + set x ok } } } } } msg }] - set r2 [child eval { set msg }] - interp delete child + set r2 [slave eval { set msg }] + interp delete slave list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} -test interp-29.3.9a {recursion limit error reporting} { - interp create child - after 0 {interp recursionlimit child 6} - set r1 [child eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - eval { # 5 - update - set x ok - } - } - } - } - } msg - }] - set r2 [child eval { set msg }] - interp delete child - list $r1 $r2 -} {0 ok} -test interp-29.3.9b {recursion limit error reporting} { - interp create child - after 0 {interp recursionlimit child 6} - set r1 [child eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - eval { # 5 - set set set - $set x ok - } - } - } - } - } msg - }] - set r2 [child eval { set msg }] - interp delete child - list $r1 $r2 -} {0 ok} -test interp-29.3.10a {recursion limit error reporting} { - interp create child - after 0 {child recursionlimit 4} - set r1 [child eval { + +test interp-29.3.9 {recursion limit error reporting} { + interp create slave + after 0 {interp recursionlimit slave 6} + set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2777,117 +2688,77 @@ test interp-29.3.10a {recursion limit error reporting} { } } msg }] - set r2 [child eval { set msg }] - interp delete child + set r2 [slave eval { set msg }] + interp delete slave list $r1 $r2 } {0 ok} -test interp-29.3.10b {recursion limit error reporting} { - interp create child - after 0 {child recursionlimit 4} - set r1 [child eval { + +test interp-29.3.10 {recursion limit error reporting} { + interp create slave + after 0 {slave recursionlimit 4} + set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 - update eval { # 5 - set x ok + update + set x ok } } } } } msg }] - set r2 [child eval { set msg }] - interp delete child + set r2 [slave eval { set msg }] + interp delete slave list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} -test interp-29.3.11a {recursion limit error reporting} { - interp create child - after 0 {child recursionlimit 5} - set r1 [child eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - eval { # 5 - update - set x ok - } - } - } - } - } msg - }] - set r2 [child eval { set msg }] - interp delete child - list $r1 $r2 -} {0 ok} -test interp-29.3.11b {recursion limit error reporting} { - interp create child - after 0 {child recursionlimit 5} - set r1 [child eval { + +test interp-29.3.11 {recursion limit error reporting} { + interp create slave + after 0 {slave recursionlimit 5} + set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 - update - set set set - $set x ok + update + set x ok } } } } } msg }] - set r2 [child eval { set msg }] - interp delete child + set r2 [slave eval { set msg }] + interp delete slave list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} -test interp-29.3.12a {recursion limit error reporting} { - interp create child - after 0 {child recursionlimit 6} - set r1 [child eval { - catch { # nesting level 1 - eval { # 2 - eval { # 3 - eval { # 4 - eval { # 5 - update - set x ok - } - } - } - } - } msg - }] - set r2 [child eval { set msg }] - interp delete child - list $r1 $r2 -} {0 ok} -test interp-29.3.12b {recursion limit error reporting} { - interp create child - after 0 {child recursionlimit 6} - set r1 [child eval { + +test interp-29.3.12 {recursion limit error reporting} { + interp create slave + after 0 {slave recursionlimit 6} + set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 - update - set set set - $set x ok + update + set x ok } } } } } msg }] - set r2 [child eval { set msg }] - interp delete child + set r2 [slave eval { set msg }] + interp delete slave list $r1 $r2 } {0 ok} + test interp-29.4.1 {recursion limit inheritance} { set i [interp create] set ii [interp eval $i { @@ -2902,7 +2773,8 @@ test interp-29.4.1 {recursion limit inheritance} { }] interp delete $i set r -} 50 +} 49 + test interp-29.4.2 {recursion limit inheritance} { set i [interp create] $i recursionlimit 50 @@ -2915,122 +2787,136 @@ test interp-29.4.2 {recursion limit inheritance} { }] interp delete $i set r -} 50 -test interp-29.5.1 {does child recursion limit affect parent?} { +} 49 + +test interp-29.5.1 {does slave recursion limit affect master?} { set before [interp recursionlimit {}] set i [interp create] interp recursionlimit $i 20000 set after [interp recursionlimit {}] - set childlimit [interp recursionlimit $i] + set slavelimit [interp recursionlimit $i] interp delete $i - list [expr {$before == $after}] $childlimit + list [expr {$before == $after}] $slavelimit } {1 20000} -test interp-29.5.2 {does child recursion limit affect parent?} { + +test interp-29.5.2 {does slave recursion limit affect master?} { set before [interp recursionlimit {}] set i [interp create] interp recursionlimit $i 20000 set after [interp recursionlimit {}] - set childlimit [$i recursionlimit] + set slavelimit [$i recursionlimit] interp delete $i - list [expr {$before == $after}] $childlimit + list [expr {$before == $after}] $slavelimit } {1 20000} -test interp-29.5.3 {does child recursion limit affect parent?} { + +test interp-29.5.3 {does slave recursion limit affect master?} { set before [interp recursionlimit {}] set i [interp create] $i recursionlimit 20000 set after [interp recursionlimit {}] - set childlimit [interp recursionlimit $i] + set slavelimit [interp recursionlimit $i] interp delete $i - list [expr {$before == $after}] $childlimit + list [expr {$before == $after}] $slavelimit } {1 20000} -test interp-29.5.4 {does child recursion limit affect parent?} { + +test interp-29.5.4 {does slave recursion limit affect master?} { set before [interp recursionlimit {}] set i [interp create] $i recursionlimit 20000 set after [interp recursionlimit {}] - set childlimit [$i recursionlimit] + set slavelimit [$i recursionlimit] interp delete $i - list [expr {$before == $after}] $childlimit + list [expr {$before == $after}] $slavelimit } {1 20000} + test interp-29.6.1 {safe interpreter recursion limit} { - interp create child -safe - set n [interp recursionlimit child] - interp delete child + interp create slave -safe + set n [interp recursionlimit slave] + interp delete slave set n } 1000 + test interp-29.6.2 {safe interpreter recursion limit} { - interp create child -safe - set n [child recursionlimit] - interp delete child + interp create slave -safe + set n [slave recursionlimit] + interp delete slave set n } 1000 + test interp-29.6.3 {safe interpreter recursion limit} { - interp create child -safe - set n1 [interp recursionlimit child 42] - set n2 [interp recursionlimit child] - interp delete child + interp create slave -safe + set n1 [interp recursionlimit slave 42] + set n2 [interp recursionlimit slave] + interp delete slave list $n1 $n2 } {42 42} + test interp-29.6.4 {safe interpreter recursion limit} { - interp create child -safe - set n1 [child recursionlimit 42] - set n2 [interp recursionlimit child] - interp delete child + interp create slave -safe + set n1 [slave recursionlimit 42] + set n2 [interp recursionlimit slave] + interp delete slave list $n1 $n2 } {42 42} + test interp-29.6.5 {safe interpreter recursion limit} { - interp create child -safe - set n1 [interp recursionlimit child 42] - set n2 [child recursionlimit] - interp delete child + interp create slave -safe + set n1 [interp recursionlimit slave 42] + set n2 [slave recursionlimit] + interp delete slave list $n1 $n2 } {42 42} + test interp-29.6.6 {safe interpreter recursion limit} { - interp create child -safe - set n1 [child recursionlimit 42] - set n2 [child recursionlimit] - interp delete child + interp create slave -safe + set n1 [slave recursionlimit 42] + set n2 [slave recursionlimit] + interp delete slave list $n1 $n2 } {42 42} + test interp-29.6.7 {safe interpreter recursion limit} { - interp create child -safe - set n1 [child recursionlimit 42] - set n2 [child recursionlimit] - interp delete child + interp create slave -safe + set n1 [slave recursionlimit 42] + set n2 [slave recursionlimit] + interp delete slave list $n1 $n2 } {42 42} + test interp-29.6.8 {safe interpreter recursion limit} { - interp create child -safe - set n [catch {child eval {interp recursionlimit {} 42}} msg] - interp delete child + interp create slave -safe + set n [catch {slave eval {interp recursionlimit {} 42}} msg] + interp delete slave list $n $msg } {1 {permission denied: safe interpreters cannot change recursion limit}} + test interp-29.6.9 {safe interpreter recursion limit} { - interp create child -safe + interp create slave -safe set result [ - child eval { - interp create child2 -safe + slave eval { + interp create slave2 -safe set n [catch { - interp recursionlimit child2 42 + interp recursionlimit slave2 42 } msg] list $n $msg } ] - interp delete child + interp delete slave set result } {1 {permission denied: safe interpreters cannot change recursion limit}} + test interp-29.6.10 {safe interpreter recursion limit} { - interp create child -safe + interp create slave -safe set result [ - child eval { - interp create child2 -safe + slave eval { + interp create slave2 -safe set n [catch { - child2 recursionlimit 42 + slave2 recursionlimit 42 } msg] list $n $msg } ] - interp delete child + interp delete slave set result } {1 {permission denied: safe interpreters cannot change recursion limit}} @@ -3071,12 +2957,13 @@ test interp-31.1 {alias invocation scope} { upvar 1 $varName localVar set localVar $value } + interp alias {} myNewSet {} mySet proc testMyNewSet {value} { myNewSet a $value return $a } - unset -nocomplain a + catch {unset a} set result [testMyNewSet "ok"] rename testMyNewSet {} rename mySet {} @@ -3084,9 +2971,8 @@ test interp-31.1 {alias invocation scope} { set result } ok -test interp-32.1 {parent's working directory should be inherited by a child interp} -setup { +test interp-32.1 {parent's working directory should be inherited by a child interp} { cd [temporaryDirectory] -} -body { set parent [pwd] set i [interp create] set child [$i eval pwd] @@ -3099,11 +2985,10 @@ test interp-32.1 {parent's working directory should be inherited by a child inte cd .. file delete cwd_test interp delete $i + cd [workingDirectory] expr {[string equal $parent $child] ? 1 : "\{$parent\} != \{$child\}"} -} -cleanup { - cd [workingDirectory] -} -result 1 +} 1 test interp-33.1 {refCounting for target words of alias [Bug 730244]} { # This test will panic if Bug 730244 is not fixed. @@ -3171,7 +3056,7 @@ test interp-34.3.1 {basic test of limits - pure inside-command loop} -body { } } # We use a time limit here; command limits don't trap this case - $i limit time -seconds [expr {[clock seconds] + 2}] + $i limit time -seconds [expr {[clock seconds]+2}] $i eval foobar } -returnCodes error -result {time limit exceeded} -cleanup { interp delete $i @@ -3193,8 +3078,8 @@ test interp-34.4 {limits with callbacks: extending limits} -setup { } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command "cb2 [expr {$curlim + 100}]" \ - -value [expr {$curlim + 10}] + $i limit command -command "cb2 [expr $curlim+100]" \ + -value [expr {$curlim+10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c } -result {6 4 b} -cleanup { @@ -3222,7 +3107,7 @@ test interp-34.5 {limits with callbacks: removing limits} -setup { } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command "cb2 {}" -value [expr {$curlim + 10}] + $i limit command -command "cb2 {}" -value [expr {$curlim+10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c } -result {6 4 b} -cleanup { @@ -3247,7 +3132,7 @@ test interp-34.6 {limits with callbacks: removing limits and handlers} -setup { } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command cb2 -value [expr {$curlim + 10}] + $i limit command -command cb2 -value [expr {$curlim+10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c } -result {6 4 b} -cleanup { @@ -3266,7 +3151,7 @@ test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { proc cb2 {args} { global c i curlim set c b - $i limit command -value [expr {$curlim + 1000}] + $i limit command -value [expr {$curlim+1000}] trapToParent } } @@ -3289,7 +3174,7 @@ test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { set c a interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command cb2 -value [expr {$curlim + 10}] + $i limit command -command cb2 -value [expr {$curlim+10}] } $i eval { $i eval { @@ -3304,7 +3189,7 @@ test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { # Bug 1085023 test interp-34.8 {time limits trigger in vwaits} -body { set i [interp create] - interp limit $i time -seconds [expr {[clock seconds] + 1}] -granularity 1 + interp limit $i time -seconds [expr {[clock seconds]+1}] -granularity 1 $i eval { set x {} vwait x @@ -3321,7 +3206,7 @@ test interp-34.9 {time limits trigger in blocking after} { } msg] set t1 [clock seconds] interp delete $i - list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] + list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] } {1 {time limit exceeded} OK} test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { set i [interp create] @@ -3352,8 +3237,8 @@ test interp-34.11 {time limit extension in callbacks} -setup { } -body { set i [interp create] set t0 [clock seconds] - $i limit time -seconds [expr {$t0 + 1}] -granularity 1 \ - -command "cb1 $i [expr {$t0 + 2}]" + $i limit time -seconds [expr {$t0+1}] -granularity 1 \ + -command "cb1 $i [expr {$t0+2}]" set ::result {} lappend ::result [catch { $i eval { @@ -3380,8 +3265,8 @@ test interp-34.12 {time limit extension in callbacks} -setup { } -body { set i [interp create] set t0 [clock seconds] - set ::times "[expr {$t0 + 2}] [expr {$t0 + 100}]" - $i limit time -seconds [expr {$t0 + 1}] -granularity 1 -command "cb1 $i" + set ::times "[expr {$t0+2}] [expr {$t0+100}]" + $i limit time -seconds [expr {$t0+1}] -granularity 1 -command "cb1 $i" set ::result {} lappend ::result [catch { $i eval { @@ -3412,10 +3297,10 @@ test interp-34.13 {time limit granularity and vwait: Bug 2891362} -setup { test interp-35.1 {interp limit syntax} -body { interp limit -} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"} +} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"} test interp-35.2 {interp limit syntax} -body { interp limit {} -} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"} +} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"} test interp-35.3 {interp limit syntax} -body { interp limit {} foo } -returnCodes error -result {bad limit type "foo": must be commands or time} @@ -3524,7 +3409,7 @@ test interp-35.19 {interp limit syntax} -body { interp limit $i time -seconds -1 } -cleanup { interp delete $i -} -match glob -returnCodes error -result {seconds must be between 0 and *} +} -returnCodes error -result {seconds must be at least 0} test interp-35.20 {interp limit syntax} -body { set i [interp create] interp limit $i time -millis foobar @@ -3536,7 +3421,7 @@ test interp-35.21 {interp limit syntax} -body { interp limit $i time -millis -1 } -cleanup { interp delete $i -} -match glob -returnCodes error -result {milliseconds must be between 0 and *} +} -returnCodes error -result {milliseconds must be at least 0} test interp-35.22 {interp time limits normalize milliseconds} -body { set i [interp create] interp limit $i time -seconds 1 -millis 1500 @@ -3555,58 +3440,59 @@ test interp-35.24 {interp time limits can't touch current interp} -body { test interp-36.1 {interp bgerror syntax} -body { interp bgerror } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} -test interp-36.2 {interp bgerror syntax} -body { +test interp-36.2 {interp bgerror syntax} -body { interp bgerror x y z } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} test interp-36.3 {interp bgerror syntax} -setup { - interp create child + interp create slave } -body { - child bgerror x y + slave bgerror x y } -cleanup { - interp delete child -} -returnCodes error -result {wrong # args: should be "child bgerror ?cmdPrefix?"} -test interp-36.4 {ChildBgerror syntax} -setup { - interp create child + interp delete slave +} -returnCodes error -result {wrong # args: should be "slave bgerror ?cmdPrefix?"} +test interp-36.4 {SlaveBgerror syntax} -setup { + interp create slave } -body { - child bgerror \{ + slave bgerror \{ } -cleanup { - interp delete child + interp delete slave } -returnCodes error -result {cmdPrefix must be list of length >= 1} -test interp-36.5 {ChildBgerror syntax} -setup { - interp create child +test interp-36.5 {SlaveBgerror syntax} -setup { + interp create slave } -body { - child bgerror {} + slave bgerror {} } -cleanup { - interp delete child + interp delete slave } -returnCodes error -result {cmdPrefix must be list of length >= 1} -test interp-36.6 {ChildBgerror returns handler} -setup { - interp create child +test interp-36.6 {SlaveBgerror returns handler} -setup { + interp create slave } -body { - child bgerror {foo bar soom} + slave bgerror {foo bar soom} } -cleanup { - interp delete child + interp delete slave } -result {foo bar soom} -test interp-36.7 {ChildBgerror sets error handler of child [1999035]} -setup { - interp create child - child alias handler handler - child bgerror handler + +test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { + interp create slave + slave alias handler handler + slave bgerror handler variable result {untouched} proc handler {args} { - variable result - set result [lindex $args 0] + variable result + set result [lindex $args 0] } } -body { - child eval { - variable done {} - after 0 error foo - after 10 [list ::set [namespace which -variable done] {}] - vwait [namespace which -variable done] + slave eval { + variable done {} + after 0 error foo + after 10 [list ::set [namespace which -variable done] {}] + vwait [namespace which -variable done] } set result } -cleanup { variable result {} - unset -nocomplain result - interp delete child + unset result + interp delete slave } -result foo test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { @@ -3615,10 +3501,10 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { set result {} } -body { interp create {a b} -safe - lappend result [interp eval a {expr {min(5,2,3)*max(7,13,11)}}] - lappend result [interp eval {a b} {expr {min(5,2,3)*max(7,13,11)}}] + lappend result [interp eval a {expr min(5,2,3)*max(7,13,11)}] + lappend result [interp eval {a b} {expr min(5,2,3)*max(7,13,11)}] } -cleanup { - unset -nocomplain result + unset result interp delete a } -result {26 26} @@ -3639,7 +3525,7 @@ test interp-38.2 {interp debug env var} -setup { } -body { interp debug a } -cleanup { - unset -nocomplain ::env(TCL_INTERP_DEBUG_FRAME) + unset ::env(TCL_INTERP_DEBUG_FRAME) interp delete a } -result {-frame 1} test interp-38.3 {interp debug wrong args} -body { @@ -3647,10 +3533,10 @@ test interp-38.3 {interp debug wrong args} -body { } -returnCodes { error } -result {wrong # args: should be "interp debug path ?-frame ?bool??"} -test interp-38.4 {interp debug basic setup} -constraints {!singleTestInterp} -body { +test interp-38.4 {interp debug basic setup} -body { interp debug {} } -result {-frame 0} -test interp-38.5 {interp debug basic setup} -constraints {!singleTestInterp} -body { +test interp-38.5 {interp debug basic setup} -body { interp debug {} -f } -result {0} test interp-38.6 {interp debug basic setup} -body { @@ -3664,16 +3550,10 @@ test interp-38.8 {interp debug basic setup} -body { } -returnCodes { error } -result {wrong # args: should be "interp debug path ?-frame ?bool??"} - + # cleanup -unset -nocomplain hidden_cmds -foreach i [interp children] { +foreach i [interp slaves] { interp delete $i } ::tcltest::cleanupTests return - -# Local Variables: -# mode: tcl -# fill-column: 78 -# End: |