cpython.git - https://github.com/python/cpython.git

diff options

Diffstat (limited to 'PC')

-rw-r--r--

640

2 files changed, 339 insertions, 339 deletions

# This file tests the multiple interpreter facility of Tcl # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # 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.1 namespace import -force ::tcltest::* } testConstraint testinterpdelete [llength [info commands testinterpdelete]] set hidden_cmds {cd encoding exec exit fconfigure glob load open pwd socket source 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:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} 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, 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-0.6 was removed # test interp-1.6 {options for interp command} -returnCodes error -body { interp slaves foo bar zop } -result {wrong # args: should be "interp slaves ?path?"} test interp-1.7 {options for interp command} -returnCodes error -body { interp hello } -result {bad option "hello": must be alias, aliases, bgerror, cancel, 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} -returnCodes error -body { interp -froboz } -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, 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} -returnCodes error -body { interp -froboz -safe } -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, 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} -returnCodes error -body { interp target } -result {wrong # args: should be "interp target path alias"} # Part 1: Basic interpreter creation tests: test interp-2.1 {basic interpreter creation} { interp create a } a test interp-2.2 {basic interpreter creation} { catch {interp create} } 0 test interp-2.3 {basic interpreter creation} { catch {interp create -safe} } 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 test interp-2.6 {basic interpreter creation} { interp create d -safe } d test interp-2.7 {basic interpreter creation} { list [catch {interp create -froboz} msg] $msg } {1 {bad option "-froboz": must be -safe or --}} test interp-2.8 {basic interpreter creation} { interp create -- -froboz } -froboz test interp-2.9 {basic interpreter creation} { interp create -safe -- -froboz1 } -froboz1 test interp-2.10 {basic interpreter creation} { interp create {a x1} interp create {a x2} interp create {a x3} -safe } {a x3} test interp-2.11 {anonymous interps vs existing procs} { set x [interp create] regexp "interp(\[0-9]+)" $x dummy thenum interp delete $x proc interp$thenum {} {} set x [interp create] regexp "interp(\[0-9]+)" $x dummy anothernum 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 proc interp$thenum {} {} set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy anothernum 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 slaves] { interp delete $i } # 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 slaves} { interp create a interp exists a } 1 test interp-3.3 {testing interp exists and interp slaves} { interp exists nonexistent } 0 test interp-3.4 {testing interp exists and interp slaves} -body { interp slaves a b c } -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} test interp-3.5 {testing interp exists and interp slaves} -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 slaves} { interp exists } 1 test interp-3.7 {testing interp exists and interp slaves} { interp slaves } a test interp-3.8 {testing interp exists and interp slaves} -body { interp slaves a b c } -returnCodes error -result {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 slaves a]} } 1 test interp-3.10 {testing interp exists and interp slaves} { interp exists {a a2} } 1 # Part 3: Testing "interp delete" test interp-3.11 {testing interp delete} { interp delete } "" 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.4 {testing interp delete} { interp delete } "" test interp-4.5 {testing interp delete} { interp create a interp create {a x1} interp delete {a x1} expr {"x1" in [interp slaves a]} } 0 test interp-4.6 {testing interp delete} { interp create c1 interp create c2 interp create c3 interp delete c1 c2 c3 } "" test interp-4.7 {testing interp delete} -returnCodes error -body { 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} foreach i [interp slaves] { interp delete $i } # Part 4: Consistency checking - all nondeleted interpreters should be # there: test interp-5.1 {testing consistency} { interp slaves } "" test interp-5.2 {testing consistency} { interp exists a } 0 test interp-5.3 {testing consistency} { interp exists nonexistent } 0 # Recreate interpreter "a" 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 } 8 test interp-6.2 {testing eval} -returnCodes error -body { a eval foo } -result {invalid command name "foo"} test interp-6.3 {testing eval} { a eval {proc foo {} {expr 3 + 5}} a eval foo } 8 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} frob } 36 test interp-6.6 {testing eval} -returnCodes error -body { interp eval {a x2} foo } -result {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_master } foo test interp-7.2 {testing basic alias creation} { a alias bar in_master a1 a2 a3 } bar # Test 6.3 has been deleted. test interp-7.3 {testing basic alias creation} { a alias foo } in_master test interp-7.4 {testing basic alias creation} { a alias bar } {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"} # Part 7: testing basic alias invocation test interp-8.1 {testing basic alias invocation} { catch {interp create a} a alias foo in_master a eval foo 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_master a1 a2 a3 a eval bar s1 s2 s3 } {seen in master: {a1 a2 a3 s1 s2 s3}} test interp-8.3 {testing basic alias invocation} -returnCodes error -body { catch {interp create a} a alias } -result {wrong # args: should be "a alias aliasName ?targetName? ?arg ...?"} # 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-master list [catch {a eval zop} msg] $msg } {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-master proc nonexistent-command-in-master {} {return i_exist!} a eval zop } i_exist! test interp-9.3 {testing aliases for hidden commands} { catch {interp create a} a eval {proc p {} {return ENTER_A}} interp alias {} p a p set res {} lappend res [list [catch p msg] $msg] interp hide a p lappend res [list [catch p msg] $msg] rename p {} interp delete a set res } {{0 ENTER_A} {1 {invalid command name "p"}}} test interp-9.4 {testing aliases and namespace commands} { proc p {} {return GLOBAL} namespace eval tst { proc p {} {return NAMESPACE} } interp alias {} a {} p set res [a] lappend res [namespace eval tst a] rename p {} rename a {} namespace delete tst set res } {GLOBAL GLOBAL} if {[info command nonexistent-command-in-master] != ""} { rename nonexistent-command-in-master {} } # Part 9: Aliasing between interpreters test interp-10.1 {testing aliasing between interpreters} { catch {interp delete a} catch {interp delete b} interp create a interp create b interp alias a a_alias b b_alias 1 2 3 } a_alias test interp-10.2 {testing aliasing between interpreters} { catch {interp delete a} catch {interp delete b} interp create a interp create b b eval {proc b_alias {args} {return [list got $args]}} interp alias a a_alias b b_alias 1 2 3 a eval a_alias a b c } {got {1 2 3 a b c}} test interp-10.3 {testing aliasing between interpreters} { catch {interp delete a} catch {interp delete b} interp create a interp create b interp alias a a_alias b b_alias 1 2 3 list [catch {a eval a_alias a b c} msg] $msg } {1 {invalid command name "b_alias"}} test interp-10.4 {testing aliasing between interpreters} { catch {interp delete a} interp create a a alias a_alias puts a aliases } a_alias test interp-10.5 {testing aliasing between interpreters} { catch {interp delete a} catch {interp delete b} interp create a interp create b a alias a_alias puts interp alias a a_del b b_del interp delete b a aliases } a_alias test interp-10.6 {testing aliasing between interpreters} { catch {interp delete a} catch {interp delete b} interp create a interp create b interp alias a a_command b b_command a1 a2 a3 b alias b_command in_master b1 b2 b3 a eval a_command 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 interp alias "" foo a zoppo a eval {proc zoppo {x} {list $x $x $x}} set x [foo 33] a eval {rename zoppo {}} interp alias "" foo a {} return $x } {33 33 33} # Part 10: Testing "interp target" test interp-11.1 {testing interp target} { list [catch {interp target} msg] $msg } {1 {wrong # args: should be "interp target path alias"}} test interp-11.2 {testing interp target} { list [catch {interp target nosuchinterpreter foo} msg] $msg } {1 {could not find interpreter "nosuchinterpreter"}} test interp-11.3 {testing interp target} { catch {interp delete a} interp create a a alias boo no_command interp target a boo } "" test interp-11.4 {testing interp target} { catch {interp delete x1} interp create x1 x1 eval interp create x2 x1 eval x2 eval interp create x3 catch {interp delete y1} interp create y1 y1 eval interp create y2 y1 eval y2 eval interp create y3 interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand interp target {x1 x2 x3} xcommand } {y1 y2 y3} test interp-11.5 {testing interp target} { catch {interp delete x1} interp create x1 interp create {x1 x2} interp create {x1 x2 x3} catch {interp delete y1} interp create y1 interp create {y1 y2} interp create {y1 y2 y3} interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand list [catch {x1 eval {interp target {x2 x3} xcommand}} msg] $msg } {1 {target interpreter for alias "xcommand" in path "x2 x3" is not my descendant}} test interp-11.6 {testing interp target} { foreach a [interp aliases] { rename $a {} } list [catch {interp target {} foo} msg] $msg } {1 {alias "foo" in path "" not found}} test interp-11.7 {testing interp target} { catch {interp delete a} interp create a list [catch {interp target a foo} msg] $msg } {1 {alias "foo" in path "a" not found}} # Part 11: testing "interp issafe" test interp-12.1 {testing interp issafe} { interp issafe } 0 test interp-12.2 {testing interp issafe} { catch {interp delete a} interp create a interp issafe a } 0 test interp-12.3 {testing interp issafe} { catch {interp delete a} interp create a interp create {a x3} -safe interp issafe {a x3} } 1 test interp-12.4 {testing interp issafe} { catch {interp delete a} interp create a interp create {a x3} -safe interp create {a x3 foo} interp issafe {a x3 foo} } 1 # Part 12: testing interpreter object command "issafe" sub-command test interp-13.1 {testing foo issafe} { catch {interp delete a} interp create a a issafe } 0 test interp-13.2 {testing foo issafe} { catch {interp delete a} interp create a interp create {a x3} -safe a eval x3 issafe } 1 test interp-13.3 {testing foo issafe} { catch {interp delete a} 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} { catch {interp create a} list [catch {a issafe too many args} msg] $msg } {1 {wrong # args: should be "a issafe"}} # part 14: testing interp aliases test interp-14.1 {testing interp aliases} { interp aliases } "" test interp-14.2 {testing interp aliases} { catch {interp delete a} 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} { catch {interp delete a} 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 master} { # SF Bug 641195 catch {interp delete a} interp create a list [catch {interp alias "" a a eval} msg] $msg [info commands a] } {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 catch {a 1 2} set ::errorInfo } -cleanup { rename setx {} rename a {} } -result {wrong # args: should be "a x" while executing "a 1 2"} test interp-14.6 {testing interp-alias: wrong # args} -setup { proc setx x {set x} catch {interp delete a} interp create a } -body { interp alias a a {} setx catch {a eval a 1 2} set ::errorInfo } -cleanup { rename setx {} interp delete a } -result {wrong # args: should be "a x" invoked from within "a 1 2" invoked from within "a eval a 1 2"} test interp-14.7 {testing interp-alias: wrong # args} -setup { proc setx x {set x} catch {interp delete a} interp create a } -body { interp alias a a {} setx a eval { catch {a 1 2} set ::errorInfo } } -cleanup { rename setx {} interp delete a } -result {wrong # args: should be "a x" invoked from within "a 1 2"} test interp-14.8 {testing interp-alias: error messages} -body { proc setx x {return -code error x} interp alias {} a {} setx catch {a 1} set ::errorInfo } -cleanup { rename setx {} rename a {} } -result {x while executing "a 1"} test interp-14.9 {testing interp-alias: error messages} -setup { proc setx x {return -code error x} catch {interp delete a} interp create a } -body { interp alias a a {} setx catch {a eval a 1} set ::errorInfo } -cleanup { rename setx {} interp delete a } -result {x invoked from within "a 1" invoked from within "a eval a 1"} test interp-14.10 {testing interp-alias: error messages} -setup { proc setx x {return -code error x} catch {interp delete a} interp create a } -body { interp alias a a {} setx a eval { catch {a 1} set ::errorInfo } } -cleanup { rename setx {} interp delete a } -result {x invoked from within "a 1"} # part 15: testing file sharing test interp-15.1 {testing file sharing} { catch {interp delete z} interp create z z eval close stdout list [catch {z eval puts hello} msg] $msg } {1 {can not find channel named "stdout"}} test interp-15.2 {testing file sharing} -body { catch {interp delete z} interp create z set f [open [makeFile {} file-15.2] w] interp share "" $f z z eval puts $f hello z eval close $f close $f } -cleanup { removeFile file-15.2 } -result "" test interp-15.3 {testing file sharing} { catch {interp delete xsafe} interp create xsafe -safe list [catch {xsafe eval puts hello} msg] $msg } {1 {can not find channel named "stdout"}} test interp-15.4 {testing file sharing} -body { catch {interp delete xsafe} interp create xsafe -safe set f [open [makeFile {} file-15.4] w] interp share "" $f xsafe xsafe eval puts $f hello xsafe eval close $f close $f } -cleanup { removeFile file-15.4 } -result "" test interp-15.5 {testing file sharing} { catch {interp delete xsafe} interp create xsafe -safe interp share "" stdout xsafe list [catch {xsafe eval gets stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} test interp-15.6 {testing file sharing} -body { catch {interp delete xsafe} interp create xsafe -safe set f [open [makeFile {} file-15.6] w] interp share "" $f xsafe set x [list [catch [list xsafe eval gets $f] msg] $msg] xsafe eval close $f close $f string compare [string tolower $x] \ [list 1 [format "channel \"%s\" wasn't opened for reading" $f]] } -cleanup { removeFile file-15.6 } -result 0 test interp-15.7 {testing file transferring} -body { catch {interp delete xsafe} interp create xsafe -safe set f [open [makeFile {} file-15.7] w] interp transfer "" $f xsafe xsafe eval puts $f hello xsafe eval close $f } -cleanup { removeFile file-15.7 } -result "" test interp-15.8 {testing file transferring} -body { catch {interp delete xsafe} interp create xsafe -safe set f [open [makeFile {} file-15.8] w] interp transfer "" $f xsafe xsafe eval close $f set x [list [catch {close $f} msg] $msg] string compare [string tolower $x] \ [list 1 [format "can not find channel named \"%s\"" $f]] } -cleanup { removeFile file-15.8 } -result 0 # # Torture tests for interpreter deletion order # proc kill {} {interp delete xxx} test interp-15.9 {testing deletion order} { catch {interp delete xxx} interp create xxx xxx alias kill kill list [catch {xxx eval kill} msg] $msg } {0 {}} test interp-16.1 {testing deletion order} { catch {interp delete xxx} interp create xxx interp create {xxx yyy} interp alias {xxx yyy} kill "" kill list [catch {interp eval {xxx yyy} kill} msg] $msg } {0 {}} test interp-16.2 {testing deletion order} { catch {interp delete xxx} interp create xxx interp create {xxx yyy} interp alias {xxx yyy} kill "" kill list [catch {xxx eval yyy eval kill} msg] $msg } {0 {}} test interp-16.3 {testing deletion order} { catch {interp delete xxx} interp create xxx interp create ddd xxx alias kill kill interp alias ddd kill xxx kill set x [ddd eval kill] interp delete ddd set x } "" test interp-16.4 {testing deletion order} { catch {interp delete xxx} interp create xxx interp create {xxx yyy} interp alias {xxx yyy} kill "" kill interp create ddd interp alias ddd kill {xxx yyy} kill set x [ddd eval kill] interp delete ddd set x } "" test interp-16.5 {testing deletion order, bgerror} { catch {interp delete xxx} interp create xxx xxx eval {proc bgerror {args} {exit}} xxx alias exit kill xxx proc kill {i} {interp delete $i} xxx eval after 100 expr a + b after 200 update interp exists xxx } 0 # # Alias loop prevention testing. # test interp-17.1 {alias loop prevention} { list [catch {interp alias {} a {} a} msg] $msg } {1 {cannot define or rename alias "a": would create a loop}} test interp-17.2 {alias loop prevention} { catch {interp delete x} interp create x x alias a loop list [catch {interp alias {} loop x a} msg] $msg } {1 {cannot define or rename alias "loop": would create a loop}} test interp-17.3 {alias loop prevention} { catch {interp delete x} interp create x interp alias x a x b list [catch {interp alias x b x a} msg] $msg } {1 {cannot define or rename alias "b": would create a loop}} test interp-17.4 {alias loop prevention} { catch {interp delete x} interp create x interp alias x b x a list [catch {x eval rename b a} msg] $msg } {1 {cannot define or rename alias "a": would create a loop}} test interp-17.5 {alias loop prevention} { catch {interp delete x} interp create x x alias z l1 interp alias {} l2 x z list [catch {rename l2 l1} msg] $msg } {1 {cannot define or rename alias "l1": would create a loop}} test interp-17.6 {alias loop prevention} { catch {interp delete x} interp create x interp alias x a x b x eval rename a c list [catch {x eval rename c b} msg] $msg } {1 {cannot define or rename alias "b": would create a loop}} # # 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 slaves} testinterpdelete { list [catch {testinterpdelete} msg] $msg } {1 {wrong # args: should be "testinterpdelete path"}} 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 slaves} testinterpdelete { catch {interp delete a} interp create a interp create {a b} testinterpdelete {a b} } "" 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 slaves} testinterpdelete { catch {interp delete a} interp create a interp create {a b} interp alias {a b} dodel {} dodel 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 slaves} testinterpdelete { catch {interp delete a} interp create a interp create {a b} interp alias {a b} dodel {} dodel proc dodel {x} {testinterpdelete $x} list [catch {interp eval {a b} {dodel a}} msg] $msg } {0 {}} test interp-18.7 {eval in deleted interp} { catch {interp delete a} interp create a a eval { proc dodel {} { delme dosomething else } proc dosomething args { puts "I should not have been called!!" } } a alias delme dela proc dela {} {interp delete a} list [catch {a eval dodel} msg] $msg } {1 {attempt to call eval in deleted interpreter}} test interp-18.8 {eval in deleted interp} { catch {interp delete a} interp create a a eval { interp create b b eval { proc dodel {} { dela } } proc foo {} { b eval dela dosomething else } proc dosomething args { puts "I should not have been called!!" } } interp alias {a b} dela {} dela proc dela {} {interp delete a} list [catch {a eval foo} msg] $msg } {1 {attempt to call eval in deleted interpreter}} 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}} 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}} # Test alias deletion test interp-19.1 {alias deletion} { catch {interp delete a} interp create a interp alias a foo a bar set s [interp alias a foo {}] interp delete a set s } {} test interp-19.2 {alias deletion} { catch {interp delete a} interp create a catch {interp alias a foo {}} msg interp delete a set msg } {alias "foo" not found} test interp-19.3 {alias deletion} { catch {interp delete a} interp create a interp alias a foo a bar interp eval a {rename foo zop} interp alias a foo a zop catch {interp eval a foo} msg interp delete a set msg } {invalid command name "bar"} test interp-19.4 {alias deletion} { catch {interp delete a} interp create a interp alias a foo a bar interp eval a {rename foo zop} catch {interp eval a foo} msg interp delete a set msg } {invalid command name "foo"} test interp-19.5 {alias deletion} { catch {interp delete a} interp create a interp eval a {proc bar {} {return 1}} interp alias a foo a bar interp eval a {rename foo zop} catch {interp eval a zop} msg interp delete a set msg } 1 test interp-19.6 {alias deletion} { catch {interp delete a} interp create a interp alias a foo a bar interp eval a {rename foo zop} interp alias a foo a zop set s [interp aliases a] interp delete a set s } {::foo foo} test interp-19.7 {alias deletion, renaming} { catch {interp delete a} interp create a interp alias a foo a bar interp eval a rename foo blotz interp alias a foo {} set s [interp aliases a] interp delete a set s } {} test interp-19.8 {alias deletion, renaming} { catch {interp delete a} interp create a interp alias a foo a bar interp eval a rename foo blotz set l "" lappend l [interp aliases a] interp alias a foo {} lappend l [interp aliases a] interp delete a set l } {foo {}} test interp-19.9 {alias deletion, renaming} { catch {interp delete a} interp create a interp alias a foo a bar interp eval a rename foo blotz interp eval a {proc foo {} {expr 34 * 34}} interp alias a foo {} set l [interp eval a foo] interp delete a set l } 1156 test interp-20.1 {interp hide, interp expose and interp invokehidden} { set a [interp create] $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} $a eval {proc foo {} {}} $a hide foo catch {$a eval foo something} msg interp delete $a set msg } {invalid command name "foo"} test interp-20.2 {interp hide, interp expose and interp invokehidden} { set a [interp create] $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} $a hide list set l "" lappend l [catch {$a eval {list 1 2 3}} msg] $msg $a expose list lappend l [catch {$a eval {list 1 2 3}} msg] $msg interp delete $a set l } {1 {invalid command name "list"} 0 {1 2 3}} test interp-20.3 {interp hide, interp expose and interp invokehidden} { set a [interp create] $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} $a hide list set l "" lappend l [catch { $a eval {list 1 2 3} } msg] $msg lappend l [catch { $a invokehidden list 1 2 3 } msg] $msg $a expose list lappend l [catch { $a eval {list 1 2 3} } msg] $msg interp delete $a set l } {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}} test interp-20.4 {interp hide, interp expose and interp invokehidden -- passing {}} { set a [interp create] $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} $a hide list set l "" lappend l [catch { $a eval {list 1 2 3} } msg] $msg lappend l [catch { $a invokehidden list {"" 1 2 3} } msg] $msg $a expose list lappend l [catch { $a eval {list 1 2 3} } msg] $msg interp delete $a set l } {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}} test interp-20.5 {interp hide, interp expose and interp invokehidden -- passing {}} { set a [interp create] $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} $a hide list set l "" lappend l [catch { $a eval {list 1 2 3} } msg] $msg lappend l [catch { $a invokehidden list {{} 1 2 3} } msg] $msg $a expose list lappend l [catch { $a eval {list 1 2 3} } msg] $msg interp delete $a set l } {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}} test interp-20.6 {interp invokehidden -- eval args} { set a [interp create] $a hide list set l "" set z 45 lappend l [catch { $a invokehidden list $z 1 2 3 } msg] $msg $a expose list lappend l [catch { $a eval list $z 1 2 3 } msg] $msg interp delete $a set l } {0 {45 1 2 3} 0 {45 1 2 3}} test interp-20.7 {interp invokehidden vs variable eval} { set a [interp create] $a hide list set z 45 set l [list [catch {$a invokehidden list {$z a b c}} msg] $msg] interp delete $a set l } {0 {{$z a b c}}} test interp-20.8 {interp invokehidden vs variable eval} { set a [interp create] $a hide list $a eval set z 89 set z 45 set l [list [catch {$a invokehidden list {$z a b c}} msg] $msg] interp delete $a set l } {0 {{$z a b c}}} test interp-20.9 {interp invokehidden vs variable eval} { set a [interp create] $a hide list $a eval set z 89 set z 45 set l "" lappend l [catch {$a invokehidden list $z {$z a b c}} msg] $msg interp delete $a set l } {0 {45 {$z a b c}}} test interp-20.10 {interp hide, interp expose and interp invokehidden} { set a [interp create] $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} $a eval {proc foo {} {}} interp hide $a foo catch {interp eval $a foo something} msg interp delete $a set msg } {invalid command name "foo"} test interp-20.11 {interp hide, interp expose and interp invokehidden} { set a [interp create] $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} interp hide $a list set l "" lappend l [catch {interp eval $a {list 1 2 3}} msg] $msg interp expose $a list lappend l [catch {interp eval $a {list 1 2 3}} msg] $msg interp delete $a set l } {1 {invalid command name "list"} 0 {1 2 3}} test interp-20.12 {interp hide, interp expose and interp invokehidden} { set a [interp create] $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} interp hide $a list set l "" lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg lappend l [catch {interp invokehidden $a list 1 2 3} msg] $msg interp expose $a list lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg interp delete $a set l } {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}} test interp-20.13 {interp hide, interp expose, interp invokehidden -- passing {}} { set a [interp create] $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} interp hide $a list set l "" lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg lappend l [catch {interp invokehidden $a list {"" 1 2 3}} msg] $msg interp expose $a list lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg interp delete $a set l } {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}} test interp-20.14 {interp hide, interp expose, interp invokehidden -- passing {}} { set a [interp create] $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} interp hide $a list set l "" lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg lappend l [catch {interp invokehidden $a list {{} 1 2 3}} msg] $msg interp expose $a list lappend l [catch {$a eval {list 1 2 3} } msg] $msg interp delete $a set l } {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}} test interp-20.15 {interp invokehidden -- eval args} { catch {interp delete a} interp create a interp hide a list set l "" set z 45 lappend l [catch {interp invokehidden a list $z 1 2 3} msg] lappend l $msg a expose list lappend l [catch {interp eval a list $z 1 2 3} msg] lappend l $msg interp delete a set l } {0 {45 1 2 3} 0 {45 1 2 3}} test interp-20.16 {interp invokehidden vs variable eval} { catch {interp delete a} interp create a interp hide a list set z 45 set l "" lappend l [catch {interp invokehidden a list {$z a b c}} msg] lappend l $msg interp delete a set l } {0 {{$z a b c}}} test interp-20.17 {interp invokehidden vs variable eval} { catch {interp delete a} interp create a interp hide a list a eval set z 89 set z 45 set l "" lappend l [catch {interp invokehidden a list {$z a b c}} msg] lappend l $msg interp delete a set l } {0 {{$z a b c}}} test interp-20.18 {interp invokehidden vs variable eval} { catch {interp delete a} interp create a interp hide a list a eval set z 89 set z 45 set l "" lappend l [catch {interp invokehidden a list $z {$z a b c}} msg] lappend l $msg interp delete a set l } {0 {45 {$z a b c}}} test interp-20.19 {interp invokehidden vs nested commands} { catch {interp delete a} interp create a a hide list set l [a invokehidden list {[list x y z] f g h} z] interp delete a set l } {{[list x y z] f g h} z} test interp-20.20 {interp invokehidden vs nested commands} { catch {interp delete a} interp create a a hide list set l [interp invokehidden a list {[list x y z] f g h} z] interp delete a set l } {{[list x y z] f g h} z} 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 $msg interp delete a set l } {0 {}} 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 $msg interp delete a set l } {0 {}} 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 $msg interp delete a set l } {1 {permission denied: safe interpreter cannot hide commands}} test interp-20.24 {interp hide vs safety} { catch {interp delete a} interp create a -safe interp create {a b} set l "" lappend l [catch {a eval {interp hide b list}} msg] lappend l $msg interp delete a set l } {1 {permission denied: safe interpreter cannot hide commands}} test interp-20.25 {interp hide vs safety} { catch {interp delete a} interp create a -safe interp create {a b} set l "" lappend l [catch {interp hide {a b} list} msg] lappend l $msg interp delete a set l } {0 {}} 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 $msg lappend l [catch {a expose list} msg] lappend l $msg interp delete a set l } {0 {} 0 {}} 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 $msg lappend l [catch {interp expose a list} msg] lappend l $msg interp delete a set l } {0 {} 0 {}} 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 $msg lappend l [catch {a eval {interp expose {} list}} msg] lappend l $msg interp delete a set l } {0 {} 1 {permission denied: safe interpreter cannot expose commands}} 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 $msg lappend l [catch {a eval {interp expose {} list}} msg] lappend l $msg interp delete a set l } {0 {} 1 {permission denied: safe interpreter cannot expose commands}} test interp-20.30 {interp expose vs safety} { catch {interp delete a} interp create a -safe interp create {a b} set l "" lappend l [catch {interp hide {a b} list} msg] lappend l $msg lappend l [catch {a eval {interp expose b list}} msg] lappend l $msg interp delete a set l } {0 {} 1 {permission denied: safe interpreter cannot expose commands}} test interp-20.31 {interp expose vs safety} { catch {interp delete a} interp create a -safe interp create {a b} set l "" lappend l [catch {interp hide {a b} list} msg] lappend l $msg lappend l [catch {interp expose {a b} list} msg] lappend l $msg interp delete a set l } {0 {} 0 {}} test interp-20.32 {interp invokehidden vs safety} { catch {interp delete a} interp create a -safe interp hide a list set l "" lappend l [catch {a eval {interp invokehidden {} list a b c}} msg] lappend l $msg interp delete a set l } {1 {not allowed to invoke hidden commands from safe interpreter}} test interp-20.33 {interp invokehidden vs safety} { catch {interp delete a} interp create a -safe interp hide a list set l "" lappend l [catch {a eval {interp invokehidden {} list a b c}} msg] lappend l $msg lappend l [catch {a invokehidden list a b c} msg] lappend l $msg interp delete a set l } {1 {not allowed to invoke hidden commands from safe interpreter}\ 0 {a b c}} test interp-20.34 {interp invokehidden vs safety} { catch {interp delete a} interp create a -safe interp create {a b} interp hide {a b} list set l "" lappend l [catch {a eval {interp invokehidden b list a b c}} msg] lappend l $msg lappend l [catch {interp invokehidden {a b} list a b c} msg] lappend l $msg interp delete a set l } {1 {not allowed to invoke hidden commands from safe interpreter}\ 0 {a b c}} test interp-20.35 {invokehidden at local level} { catch {interp delete a} interp create a a eval { proc p1 {} { set z 90 a1 set z } proc h1 {} { upvar z z set z 91 } } a hide h1 a alias a1 a1 proc a1 {} { interp invokehidden a h1 } set r [interp eval a p1] interp delete a set r } 91 test interp-20.36 {invokehidden at local level} { catch {interp delete a} interp create a a eval { set z 90 proc p1 {} { global z a1 set z } proc h1 {} { upvar z z set z 91 } } a hide h1 a alias a1 a1 proc a1 {} { interp invokehidden a h1 } set r [interp eval a p1] interp delete a set r } 91 test interp-20.37 {invokehidden at local level} { catch {interp delete a} interp create a a eval { proc p1 {} { a1 set z } proc h1 {} { upvar z z set z 91 } } a hide h1 a alias a1 a1 proc a1 {} { interp invokehidden a h1 } set r [interp eval a p1] interp delete a set r } 91 test interp-20.38 {invokehidden at global level} { catch {interp delete a} interp create a a eval { proc p1 {} { a1 set z } proc h1 {} { upvar z z set z 91 } } a hide h1 a alias a1 a1 proc a1 {} { interp invokehidden a -global h1 } set r [catch {interp eval a p1} msg] interp delete a list $r $msg } {1 {can't read "z": no such variable}} test interp-20.39 {invokehidden at global level} { catch {interp delete a} interp create a a eval { proc p1 {} { global z a1 set z } proc h1 {} { upvar z z set z 91 } } a hide h1 a alias a1 a1 proc a1 {} { interp invokehidden a -global h1 } set r [catch {interp eval a p1} msg] interp delete a list $r $msg } {0 91} test interp-20.40 {safe, invokehidden at local level} { catch {interp delete a} interp create a -safe a eval { proc p1 {} { set z 90 a1 set z } proc h1 {} { upvar z z set z 91 } } a hide h1 a alias a1 a1 proc a1 {} { interp invokehidden a h1 } set r [interp eval a p1] interp delete a set r } 91 test interp-20.41 {safe, invokehidden at local level} { catch {interp delete a} interp create a -safe a eval { set z 90 proc p1 {} { global z a1 set z } proc h1 {} { upvar z z set z 91 } } a hide h1 a alias a1 a1 proc a1 {} { interp invokehidden a h1 } set r [interp eval a p1] interp delete a set r } 91 test interp-20.42 {safe, invokehidden at local level} { catch {interp delete a} interp create a -safe a eval { proc p1 {} { a1 set z } proc h1 {} { upvar z z set z 91 } } a hide h1 a alias a1 a1 proc a1 {} { interp invokehidden a h1 } set r [interp eval a p1] interp delete a set r } 91 test interp-20.43 {invokehidden at global level} { catch {interp delete a} interp create a a eval { proc p1 {} { a1 set z } proc h1 {} { upvar z z set z 91 } } a hide h1 a alias a1 a1 proc a1 {} { interp invokehidden a -global h1 } set r [catch {interp eval a p1} msg] interp delete a list $r $msg } {1 {can't read "z": no such variable}} test interp-20.44 {invokehidden at global level} { catch {interp delete a} interp create a a eval { proc p1 {} { global z a1 set z } proc h1 {} { upvar z z set z 91 } } a hide h1 a alias a1 a1 proc a1 {} { interp invokehidden a -global h1 } set r [catch {interp eval a p1} msg] interp delete a list $r $msg } {0 91} test interp-20.45 {interp hide vs namespaces} { catch {interp delete a} interp create a a eval { namespace eval foo {} proc foo::x {} {} } set l [list [catch {interp hide a foo::x} msg] $msg] interp delete a set l } {1 {cannot use namespace qualifiers in hidden command token (rename)}} test interp-20.46 {interp hide vs namespaces} { catch {interp delete a} interp create a a eval { namespace eval foo {} proc foo::x {} {} } set l [list [catch {interp hide a foo::x x} msg] $msg] interp delete a set l } {1 {can only hide global namespace commands (use rename then hide)}} test interp-20.47 {interp hide vs namespaces} { catch {interp delete a} interp create a a eval { proc x {} {} } set l [list [catch {interp hide a x foo::x} msg] $msg] interp delete a set l } {1 {cannot use namespace qualifiers in hidden command token (rename)}} test interp-20.48 {interp hide vs namespaces} { catch {interp delete a} interp create a a eval { namespace eval foo {} proc foo::x {} {} } set l [list [catch {interp hide a foo::x bar::x} msg] $msg] interp delete a set l } {1 {cannot use namespace qualifiers in hidden command token (rename)}} test interp-20.49 {interp invokehidden -namespace} -setup { set script [makeFile { set x [namespace current] } script] interp create -safe slave } -body { slave invokehidden -namespace ::foo source $script slave eval {set ::foo::x} } -cleanup { interp delete slave removeFile script } -result ::foo test interp-20.50 {Bug 2486550} -setup { interp create slave } -body { slave hide coroutine slave invokehidden coroutine } -cleanup { interp delete slave } -returnCodes error -match glob -result * test interp-21.1 {interp hidden} { interp hidden {} } "" test interp-21.2 {interp hidden} { interp hidden } "" test interp-21.3 {interp hidden vs interp hide, interp expose} -setup { 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 { catch {interp delete a} } -body { interp create a interp hidden a } -cleanup { interp delete a } -result "" test interp-21.5 {interp hidden} -setup { catch {interp delete a} } -body { interp create -safe a lsort [interp hidden a] } -cleanup { interp delete a } -result $hidden_cmds test interp-21.6 {interp hidden vs interp hide, interp expose} -setup { catch {interp delete a} set l "" } -body { interp create a 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 { catch {interp delete a} } -body { interp create a a hidden } -cleanup { interp delete a } -result "" test interp-21.8 {interp hidden} -setup { catch {interp delete a} } -body { interp create a -safe lsort [a hidden] } -cleanup { interp delete a } -result $hidden_cmds test interp-21.9 {interp hidden vs interp hide, interp expose} -setup { catch {interp delete a} set l "" } -body { interp create a lappend l [a hidden] a hide pwd lappend l [a hidden] a expose pwd lappend l [a hidden] } -cleanup { interp delete a } -result {{} pwd {}} test interp-22.1 {testing interp marktrusted} { catch {interp delete a} interp create a set l "" lappend l [a issafe] lappend l [a marktrusted] lappend l [a issafe] interp delete a set l } {0 {} 0} test interp-22.2 {testing interp marktrusted} { catch {interp delete a} interp create a set l "" lappend l [interp issafe a] lappend l [interp marktrusted a] lappend l [interp issafe a] interp delete a set l } {0 {} 0} test interp-22.3 {testing interp marktrusted} { catch {interp delete a} interp create a -safe set l "" lappend l [a issafe] lappend l [a marktrusted] lappend l [a issafe] interp delete a set l } {1 {} 0} test interp-22.4 {testing interp marktrusted} { catch {interp delete a} interp create a -safe set l "" lappend l [interp issafe a] lappend l [interp marktrusted a] lappend l [interp issafe a] interp delete a set l } {1 {} 0} test interp-22.5 {testing interp marktrusted} { catch {interp delete a} interp create a -safe interp create {a b} catch {a eval {interp marktrusted b}} msg interp delete a set msg } {permission denied: safe interpreter cannot mark trusted} test interp-22.6 {testing interp marktrusted} { catch {interp delete a} interp create a -safe interp create {a b} catch {a eval {b marktrusted}} msg interp delete a set msg } {permission denied: safe interpreter cannot mark trusted} test interp-22.7 {testing interp marktrusted} { catch {interp delete a} interp create a -safe set l "" lappend l [interp issafe a] interp marktrusted a interp create {a b} lappend l [interp issafe a] lappend l [interp issafe {a b}] interp delete a set l } {1 0 0} test interp-22.8 {testing interp marktrusted} { catch {interp delete a} interp create a -safe set l "" lappend l [interp issafe a] interp create {a b} lappend l [interp issafe {a b}] interp marktrusted a interp create {a c} lappend l [interp issafe a] lappend l [interp issafe {a c}] interp delete a set l } {1 1 0 0} test interp-22.9 {testing interp marktrusted} { catch {interp delete a} interp create a -safe set l "" lappend l [interp issafe a] interp create {a b} lappend l [interp issafe {a b}] interp marktrusted {a b} lappend l [interp issafe a] lappend l [interp issafe {a b}] interp create {a b c} lappend l [interp issafe {a b c}] interp delete a set l } {1 1 1 0 0} test interp-23.1 {testing hiding vs aliases: unsafe interp} -setup { catch {interp delete a} set l "" } -body { interp create a lappend l [interp hidden a] a alias bar bar lappend l [interp aliases a] [interp hidden a] a hide bar lappend l [interp aliases a] [interp hidden a] a alias bar {} lappend l [interp aliases a] [interp hidden a] } -cleanup { interp delete a } -result {{} bar {} bar bar {} {}} test interp-23.2 {testing hiding vs aliases: safe interp} -setup { catch {interp delete a} set l "" } -constraints {unixOrPc} -body { interp create a -safe lappend l [lsort [interp hidden a]] a alias bar bar lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a hide bar lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a alias bar {} lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] } -cleanup { interp delete a } -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds] test interp-24.1 {result resetting on error} -setup { 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 { interp delete a } -result {1 {1 2 3} 1 {3 4 5}} test interp-24.2 {result resetting on error} -setup { 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 { interp delete a } -result {1 {1 2 3} 1 {3 4 5}} test interp-24.3 {result resetting on error} -setup { 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 { interp delete a } -result {1 {1 2 3} 1 {3 4 5}} test interp-24.4 {result resetting on error} -setup { 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} { lappend l [catch {foo 1 2 3} msg] lappend l $msg lappend l [catch {foo 3 4 5} msg] lappend l $msg } } -cleanup { interp delete a } -result {1 {1 2 3} 1 {3 4 5}} test interp-24.5 {result resetting on error} -setup { 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 { interp delete a interp delete b } -result {1 {1 2 3} 1 {3 4 5}} test interp-24.6 {result resetting on error} -setup { 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 { interp delete a interp delete b } -result {1 {1 2 3} 1 {3 4 5}} test interp-24.7 {result resetting on error} -setup { 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 { interp delete a } -result {1 {1 2 3} 1 {3 4 5}} test interp-24.8 {result resetting on error} -setup { 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 { interp delete a } -result {1 {1 2 3} 1 {3 4 5}} test interp-24.9 {result resetting on error} -setup { catch {interp delete a} set l {} } -body { interp create a interp create {a b} interp eval {a b} { proc foo args {error $args} } interp eval a { proc foo args { 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 { interp delete a } -result {1 {1 2 3} 1 {3 4 5}} test interp-24.10 {result resetting on error} -setup { catch {interp delete a} set l {} } -body { interp create a -safe interp create {a b} interp eval {a b} { proc foo args {error $args} } interp eval a { proc foo args { 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 { interp delete a } -result {1 {1 2 3} 1 {3 4 5}} test interp-24.11 {result resetting on error} -setup { catch {interp delete a} } -body { interp create a interp create {a b} interp eval {a b} { proc foo args {error $args} } 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 } } interp eval a foo 1 2 3 } -cleanup { interp delete a } -result {1 {1 2 3} 1 {1 2 3}} test interp-24.12 {result resetting on error} -setup { catch {interp delete a} } -body { interp create a -safe interp create {a b} interp eval {a b} { proc foo args {error $args} } 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 } } interp eval a foo 1 2 3 } -cleanup { interp delete a } -result {1 {1 2 3} 1 {1 2 3}} test interp-25.1 {testing aliasing of string commands} -setup { 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 # test interp-26.1 {result code transmission : interp eval direct} { # Test that all the possibles error codes from Tcl get passed up # from the slave interp's context to the master, even though the # slave nominally thinks the command is running at the root level. catch {interp delete a} interp create a set res {} # use a for so if a return -code break 'escapes' we would notice for {set code -1} {$code<=5} {incr code} { lappend res [catch {interp eval a return -code $code} msg] } interp delete a set res } {-1 0 1 2 3 4 5} test interp-26.2 {result code transmission : interp eval indirect} { # retcode == 2 == return is special catch {interp delete a} interp create a interp eval a {proc 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} -setup { 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. proc MyTestAlias {interp 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 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] $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. # End of return code transmission section test interp-26.7 {errorInfo transmission: regular interps} -setup { set interp [interp create] } -body { 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 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 # master interpreter because it could contain sensitive information. 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 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 $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 $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] } interp eval $i {namespace eval foo {proc bar {} {error "bar called"}}} 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 { namespace eval foo2 { variable aliasTrace {} proc bar {args} { variable aliasTrace lappend aliasTrace [list [namespace current] $args] } } $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-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 } }]] } -cleanup { namespace delete foo interp delete $i } -result {{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} -setup { set i [interp create] } -constraints knownBug -body { 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}]] } -cleanup { namespace delete mfoo interp delete $i } -result {{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} 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 slave's namespace ?} -setup { set i [interp create -safe] proc master {interp args} {interp hide $interp list} } -body { $i alias master master $i set r [interp eval $i { namespace eval foo { proc list {args} { return "dummy foo::list" } master } info commands list }] } -cleanup { rename master {} interp delete $i } -result {} test interp-28.2 {master's nsName cache should not cross} -setup { set i [interp create] $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}} } -body { $i eval { set x {namespace children ::} set y [list namespace children ::] namespace delete {*}[filter [{*}$y]] set j [interp create] $j alias filter filter $j eval {namespace delete {*}[filter [namespace children ::]]} namespace eval foo {} list [filter [eval $x]] [filter [eval $y]] [filter [$j eval $x]] [filter [$j eval $y]] } } -cleanup { interp delete $i } -result {::foo ::foo {} {}} # Part 29: recursion limit # 29.1.* Argument checking # 29.2.* Reading and setting the recursion limit # 29.3.* Does the recursion limit work? # 29.4.* Recursion limit inheritance by sub-interpreters # 29.5.* Confirming the recursionlimit command does not affect the parent # 29.6.* Safe interpreter restriction 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 {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 {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 {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 {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 {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 { set n1 [interp recursionlimit {} 42] set n2 [interp recursionlimit {}] list $n1 $n2 }] 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] set n2 [interp recursionlimit $i] 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] set n2 [$i recursionlimit] 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] set n2 [interp recursionlimit $i] 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] set n2 [$i recursionlimit] interp delete $i list $n1 $n2 } {42 42} test interp-29.3.1 {recursion limit} { set i [interp create] set r [interp eval $i { interp recursionlimit {} 50 proc p {} {incr ::i; p} set i 0 list [catch p msg] $msg $i }] interp delete $i set r } {1 {too many nested evaluations (infinite loop?)} 49} test interp-29.3.2 {recursion limit} { set i [interp create] interp recursionlimit $i 50 set r [interp eval $i { proc p {} {incr ::i; p} set i 0 list [catch p msg] $msg $i }] interp delete $i set r } {1 {too many nested evaluations (infinite loop?)} 49} test interp-29.3.3 {recursion limit} { set i [interp create] $i recursionlimit 50 set r [interp eval $i { proc p {} {incr ::i; p} set i 0 list [catch p msg] $msg $i }] interp delete $i set r } {1 {too many nested evaluations (infinite loop?)} 49} test interp-29.3.4 {recursion limit error reporting} { interp create slave set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 interp recursionlimit {} 5 set x ok } } } } } msg }] 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 slave set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 interp recursionlimit {} 4 set x ok } } } } } msg }] 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 slave set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 interp recursionlimit {} 6 set x ok } } } } } msg }] set r2 [slave eval { set msg }] interp delete slave 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 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 x ok } } } } } msg }] set r2 [slave eval { set msg }] interp delete slave list $r1 $r2 } {0 ok} test interp-29.3.7b {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 update eval { # 5 set x ok } } } } } msg }] 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 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 } } } } } msg }] 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 slave after 0 {interp recursionlimit slave 4} set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 update set x ok } } } } } msg }] set r2 [slave eval { set msg }] interp delete slave list $r1 $r2 } {0 ok} test interp-29.3.8b {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 } } } } } msg }] 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 slave after 0 {interp recursionlimit slave 6} set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 update set x ok } } } } } msg }] set r2 [slave eval { set msg }] interp delete slave list $r1 $r2 } {0 ok} test interp-29.3.9b {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 eval { # 4 eval { # 5 set set set $set x ok } } } } } msg }] set r2 [slave eval { set msg }] interp delete slave list $r1 $r2 } {0 ok} test interp-29.3.10a {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 eval { # 5 update set x ok } } } } } msg }] 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 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 } } } } } msg }] 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 slave after 0 {slave recursionlimit 5} set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 update set x ok } } } } } msg }] set r2 [slave eval { set msg }] interp delete slave list $r1 $r2 } {0 ok} test interp-29.3.11b {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 } } } } } msg }] 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 slave after 0 {slave recursionlimit 6} set r1 [slave eval { catch { # nesting level 1 eval { # 2 eval { # 3 eval { # 4 eval { # 5 update set x ok } } } } } msg }] set r2 [slave eval { set msg }] interp delete slave list $r1 $r2 } {0 ok} test interp-29.3.12b {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 } } } } } msg }] 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 { interp recursionlimit {} 50 interp create }] set r [interp eval [list $i $ii] { proc p {} {incr ::i; p} set i 0 catch p set i }] interp delete $i set r } 50 test interp-29.4.2 {recursion limit inheritance} { set i [interp create] $i recursionlimit 50 set ii [interp eval $i {interp create}] set r [interp eval [list $i $ii] { proc p {} {incr ::i; p} set i 0 catch p set i }] interp delete $i set r } 50 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 slavelimit [interp recursionlimit $i] interp delete $i list [expr {$before == $after}] $slavelimit } {1 20000} 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 slavelimit [$i recursionlimit] interp delete $i list [expr {$before == $after}] $slavelimit } {1 20000} 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 slavelimit [interp recursionlimit $i] interp delete $i list [expr {$before == $after}] $slavelimit } {1 20000} 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 slavelimit [$i recursionlimit] interp delete $i list [expr {$before == $after}] $slavelimit } {1 20000} test interp-29.6.1 {safe interpreter recursion limit} { 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 slave -safe set n [slave recursionlimit] interp delete slave set n } 1000 test interp-29.6.3 {safe interpreter recursion limit} { 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 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 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 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 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 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 slave -safe set result [ slave eval { interp create slave2 -safe set n [catch { interp recursionlimit slave2 42 } msg] list $n $msg } ] 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 slave -safe set result [ slave eval { interp create slave2 -safe set n [catch { slave2 recursionlimit 42 } msg] list $n $msg } ] interp delete slave set result } {1 {permission denied: safe interpreters cannot change recursion limit}} # # Deep recursion (into interps when the regular one fails): # # still crashes... # proc p {} { # if {[catch p ret]} { # catch { # set i [interp create] # interp eval $i [list proc p {} [info body p]] # interp eval $i p # } # interp delete $i # return ok # } # return $ret # } # p # more tests needed... # Interp & stack #test interp-29.1 {interp and stack (info level)} { #} {} # End of stack-recursion tests # This test dumps core in Tcl 8.0.3! test interp-30.1 {deletion of aliases inside namespaces} { set i [interp create] $i alias ns::cmd list $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 } unset -nocomplain a set result [testMyNewSet "ok"] rename testMyNewSet {} rename mySet {} rename myNewSet {} set result } ok test interp-32.1 {parent's working directory should be inherited by a child interp} -setup { cd [temporaryDirectory] } -body { set parent [pwd] set i [interp create] set child [$i eval pwd] interp delete $i file mkdir cwd_test cd cwd_test lappend parent [pwd] set i [interp create] lappend child [$i eval pwd] cd .. file delete cwd_test interp delete $i expr {[string equal $parent $child] ? 1 : "\{$parent\} != \{$child\}"} } -cleanup { cd [workingDirectory] } -result 1 test interp-33.1 {refCounting for target words of alias [Bug 730244]} { # This test will panic if Bug 730244 is not fixed. set i [interp create] proc testHelper args {rename testHelper {}; return $args} # Note: interp names are simple words by default trace add execution testHelper enter "interp alias $i alias {} ;#" interp alias $i alias {} testHelper this $i eval alias } this test interp-34.1 {basic test of limits - calling commands} -body { set i [interp create] $i eval { proc foobar {} { for {set x 0} {$x<1000000} {incr x} { # Calls to this are not bytecoded away pid } } } $i limit command -value 1000 $i eval foobar } -returnCodes error -result {command count limit exceeded} -cleanup { interp delete $i } test interp-34.2 {basic test of limits - bytecoded commands} -body { set i [interp create] $i eval { proc foobar {} { for {set x 0} {$x<1000000} {incr x} { # Calls to this *are* bytecoded away expr {1+2+3} } } } $i limit command -value 1000 $i eval foobar } -returnCodes error -result {command count limit exceeded} -cleanup { interp delete $i } test interp-34.3 {basic test of limits - pure bytecode loop} -body { set i [interp create] $i eval { proc foobar {} { while {1} { # No bytecode at all here... } } } # We use a time limit here; command limits don't trap this case $i limit time -seconds [expr {[clock seconds]+2}] $i eval foobar } -returnCodes error -result {time limit exceeded} -cleanup { interp delete $i } test interp-34.3.1 {basic test of limits - pure inside-command loop} -body { set i [interp create] $i eval { proc foobar {} { set while while $while {1} { # No bytecode at all here... } } } # We use a time limit here; command limits don't trap this case $i limit time -seconds [expr {[clock seconds]+2}] $i eval foobar } -returnCodes error -result {time limit exceeded} -cleanup { interp delete $i } test interp-34.4 {limits with callbacks: extending limits} -setup { set i [interp create] set a 0 set b 0 set c a proc cb1 {} { global c incr ::$c } proc cb2 {newlimit args} { global c i set c b $i limit command -value $newlimit } } -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 eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c } -result {6 4 b} -cleanup { interp delete $i rename cb1 {} rename cb2 {} } # The next three tests exercise all the three ways that limit handlers # can be deleted. Fully verifying this requires additional source # code instrumentation. test interp-34.5 {limits with callbacks: removing limits} -setup { set i [interp create] set a 0 set b 0 set c a proc cb1 {} { global c incr ::$c } proc cb2 {newlimit args} { global c i set c b $i limit command -value $newlimit } } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] $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 { interp delete $i rename cb1 {} rename cb2 {} } test interp-34.6 {limits with callbacks: removing limits and handlers} -setup { set i [interp create] set a 0 set b 0 set c a proc cb1 {} { global c incr ::$c } proc cb2 {args} { global c i set c b $i limit command -value {} -command {} } } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] $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 { interp delete $i rename cb1 {} rename cb2 {} } test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { set i [interp create] $i eval { set i [interp create] proc cb1 {} { global c incr ::$c } proc cb2 {args} { global c i curlim set c b $i limit command -value [expr {$curlim+1000}] trapToParent } } proc cb3 {} { global i subi interp alias [list $i $subi] foo {} cb4 interp delete $i } proc cb4 {} { global n incr n } } -body { set subi [$i eval set i] interp alias $i trapToParent {} cb3 set n 0 $i eval { set a 0 set b 0 set c a interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] $i limit command -command cb2 -value [expr {$curlim+10}] } $i eval { $i eval { for {set i 0} {$i<10} {incr i} {foo} } } list $n [interp exists $i] } -result {4 0} -cleanup { rename cb3 {} rename cb4 {} } # 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 $i eval { set x {} vwait x } } -cleanup { interp delete $i } -returnCodes error -result {limit exceeded} test interp-34.9 {time limits trigger in blocking after} { set i [interp create] set t0 [clock seconds] interp limit $i time -seconds [expr {$t0 + 1}] -granularity 1 set code [catch { $i eval {after 10000} } msg] set t1 [clock seconds] interp delete $i 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] # Assume someone hasn't set the clock to early 1970! $i limit time -seconds 1 -granularity 4 interp alias $i log {} lappend result set result {} catch { $i eval { log 1 after 100 log 2 } } msg interp delete $i lappend result $msg } -result {1 {time limit exceeded}} test interp-34.11 {time limit extension in callbacks} -setup { proc cb1 {i t} { global result lappend result cb1 $i limit time -seconds $t -command cb2 } proc cb2 {} { global result lappend result cb2 } } -body { set i [interp create] set t0 [clock seconds] $i limit time -seconds [expr {$t0+1}] -granularity 1 \ -command "cb1 $i [expr {$t0+2}]" set ::result {} lappend ::result [catch { $i eval { for {set i 0} {$i<30} {incr i} { after 100 } } } msg] $msg set t1 [clock seconds] lappend ::result [expr {$t1-$t0>=2 ? "ok" : "$t0,$t1"}] interp delete $i return $::result } -result {cb1 cb2 1 {time limit exceeded} ok} -cleanup { rename cb1 {} rename cb2 {} } test interp-34.12 {time limit extension in callbacks} -setup { proc cb1 {i} { global result times lappend result cb1 set times [lassign $times t] $i limit time -seconds $t } } -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 ::result {} lappend ::result [catch { $i eval { for {set i 0} {$i<30} {incr i} { after 100 } } } msg] $msg set t1 [clock seconds] lappend ::result [expr {$t1-$t0>=2 ? "ok" : "$t0,$t1"}] interp delete $i return $::result } -result {cb1 cb1 0 {} ok} -cleanup { rename cb1 {} } test interp-34.13 {time limit granularity and vwait: Bug 2891362} -setup { set i [interp create -safe] } -body { $i limit time -seconds [clock add [clock seconds] 1 second] $i eval { after 2000 set x timeout vwait x return $x } } -cleanup { interp delete $i } -returnCodes error -result {limit exceeded} test interp-35.1 {interp limit syntax} -body { interp limit } -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"} test interp-35.2 {interp limit syntax} -body { interp limit {} } -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"} test interp-35.3 {interp limit syntax} -body { interp limit {} foo } -returnCodes error -result {bad limit type "foo": must be commands or time} test interp-35.4 {interp limit syntax} -body { set i [interp create] set dict [interp limit $i commands] set result {} foreach key [lsort [dict keys $dict]] { lappend result $key [dict get $dict $key] } set result } -cleanup { interp delete $i } -result {-command {} -granularity 1 -value {}} test interp-35.5 {interp limit syntax} -body { set i [interp create] interp limit $i commands -granularity } -cleanup { interp delete $i } -result 1 test interp-35.6 {interp limit syntax} -body { set i [interp create] interp limit $i commands -granularity 2 } -cleanup { interp delete $i } -result {} test interp-35.7 {interp limit syntax} -body { set i [interp create] interp limit $i commands -foobar } -cleanup { interp delete $i } -returnCodes error -result {bad option "-foobar": must be -command, -granularity, or -value} test interp-35.8 {interp limit syntax} -body { set i [interp create] interp limit $i commands -granularity foobar } -cleanup { interp delete $i } -returnCodes error -result {expected integer but got "foobar"} test interp-35.9 {interp limit syntax} -body { set i [interp create] interp limit $i commands -granularity 0 } -cleanup { interp delete $i } -returnCodes error -result {granularity must be at least 1} test interp-35.10 {interp limit syntax} -body { set i [interp create] interp limit $i commands -value foobar } -cleanup { interp delete $i } -returnCodes error -result {expected integer but got "foobar"} test interp-35.11 {interp limit syntax} -body { set i [interp create] interp limit $i commands -value -1 } -cleanup { interp delete $i } -returnCodes error -result {command limit value must be at least 0} test interp-35.12 {interp limit syntax} -body { set i [interp create] set dict [interp limit $i time] set result {} foreach key [lsort [dict keys $dict]] { lappend result $key [dict get $dict $key] } set result } -cleanup { interp delete $i } -result {-command {} -granularity 10 -milliseconds {} -seconds {}} test interp-35.13 {interp limit syntax} -body { set i [interp create] interp limit $i time -granularity } -cleanup { interp delete $i } -result 10 test interp-35.14 {interp limit syntax} -body { set i [interp create] interp limit $i time -granularity 2 } -cleanup { interp delete $i } -result {} test interp-35.15 {interp limit syntax} -body { set i [interp create] interp limit $i time -foobar } -cleanup { interp delete $i } -returnCodes error -result {bad option "-foobar": must be -command, -granularity, -milliseconds, or -seconds} test interp-35.16 {interp limit syntax} -body { set i [interp create] interp limit $i time -granularity foobar } -cleanup { interp delete $i } -returnCodes error -result {expected integer but got "foobar"} test interp-35.17 {interp limit syntax} -body { set i [interp create] interp limit $i time -granularity 0 } -cleanup { interp delete $i } -returnCodes error -result {granularity must be at least 1} test interp-35.18 {interp limit syntax} -body { set i [interp create] interp limit $i time -seconds foobar } -cleanup { interp delete $i } -returnCodes error -result {expected integer but got "foobar"} test interp-35.19 {interp limit syntax} -body { set i [interp create] interp limit $i time -seconds -1 } -cleanup { interp delete $i } -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 } -cleanup { interp delete $i } -returnCodes error -result {expected integer but got "foobar"} test interp-35.21 {interp limit syntax} -body { set i [interp create] interp limit $i time -millis -1 } -cleanup { interp delete $i } -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 list [$i limit time -seconds] [$i limit time -millis] } -cleanup { interp delete $i } -result {2 500} 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 { 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 slave } -body { slave bgerror x y } -cleanup { interp delete slave } -returnCodes error -result {wrong # args: should be "slave bgerror ?cmdPrefix?"} test interp-36.4 {SlaveBgerror syntax} -setup { interp create slave } -body { slave bgerror \{ } -cleanup { interp delete slave } -returnCodes error -result {cmdPrefix must be list of length >= 1} test interp-36.5 {SlaveBgerror syntax} -setup { interp create slave } -body { slave bgerror {} } -cleanup { interp delete slave } -returnCodes error -result {cmdPrefix must be list of length >= 1} test interp-36.6 {SlaveBgerror returns handler} -setup { interp create slave } -body { slave bgerror {foo bar soom} } -cleanup { interp delete slave } -result {foo bar soom} 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] } } -body { 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 slave } -result foo test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { catch {interp delete a} interp create a 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)}] } -cleanup { unset -nocomplain result interp delete a } -result {26 26} test interp-38.1 {interp debug one-way switch} -setup { catch {interp delete a} interp create a interp debug a -frame 1 } -body { # TIP #3xx interp debug frame is a one-way switch interp debug a -frame 0 } -cleanup { interp delete a } -result {1} test interp-38.2 {interp debug env var} -setup { catch {interp delete a} set ::env(TCL_INTERP_DEBUG_FRAME) 1 interp create a } -body { interp debug a } -cleanup { unset -nocomplain ::env(TCL_INTERP_DEBUG_FRAME) interp delete a } -result {-frame 1} test interp-38.3 {interp debug wrong args} -body { interp debug } -returnCodes { error } -result {wrong # args: should be "interp debug path ?-frame ?bool??"} test interp-38.4 {interp debug basic setup} -body { interp debug {} } -result {-frame 0} test interp-38.5 {interp debug basic setup} -body { interp debug {} -f } -result {0} test interp-38.6 {interp debug basic setup} -body { interp debug -frames } -returnCodes error -result {could not find interpreter "-frames"} test interp-38.7 {interp debug basic setup} -body { interp debug {} -frames } -returnCodes error -result {bad debug option "-frames": must be -frame} test interp-38.8 {interp debug basic setup} -body { interp debug {} -frame 0 bogus } -returnCodes { error } -result {wrong # args: should be "interp debug path ?-frame ?bool??"} # cleanup unset -nocomplain hidden_cmds foreach i [interp slaves] { interp delete $i } ::tcltest::cleanupTests return # Local Variables: # mode: tcl # fill-column: 78 # End:


context:
space:
mode: