sl@0: # This file tests the multiple interpreter facility of Tcl sl@0: # sl@0: # This file contains a collection of tests for one or more of the Tcl sl@0: # built-in commands. Sourcing this file into Tcl runs the tests and sl@0: # generates output for errors. No output means no errors were found. sl@0: # sl@0: # Copyright (c) 1995-1996 Sun Microsystems, Inc. sl@0: # Copyright (c) 1998-1999 by Scriptics Corporation. sl@0: # sl@0: # See the file "license.terms" for information on usage and redistribution sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: # sl@0: # RCS: @(#) $Id: interp.test,v 1.19.2.6 2004/10/28 00:01:07 dgp Exp $ sl@0: sl@0: if {[lsearch [namespace children] ::tcltest] == -1} { sl@0: package require tcltest 2.1 sl@0: namespace import -force ::tcltest::* sl@0: } sl@0: sl@0: # The set of hidden commands is platform dependent: sl@0: sl@0: if {"$tcl_platform(platform)" == "macintosh"} { sl@0: set hidden_cmds {beep cd echo encoding exit fconfigure file glob load ls open pwd socket source} sl@0: } else { sl@0: set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source} sl@0: } sl@0: sl@0: foreach i [interp slaves] { sl@0: interp delete $i sl@0: } sl@0: sl@0: proc equiv {x} {return $x} sl@0: sl@0: # Part 0: Check out options for interp command sl@0: test interp-1.1 {options for interp command} { sl@0: list [catch {interp} msg] $msg sl@0: } {1 {wrong # args: should be "interp cmd ?arg ...?"}} sl@0: test interp-1.2 {options for interp command} { sl@0: list [catch {interp frobox} msg] $msg sl@0: } {1 {bad option "frobox": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}} sl@0: test interp-1.3 {options for interp command} { sl@0: interp delete sl@0: } "" sl@0: test interp-1.4 {options for interp command} { sl@0: list [catch {interp delete foo bar} msg] $msg sl@0: } {1 {could not find interpreter "foo"}} sl@0: test interp-1.5 {options for interp command} { sl@0: list [catch {interp exists foo bar} msg] $msg sl@0: } {1 {wrong # args: should be "interp exists ?path?"}} sl@0: # sl@0: # test interp-0.6 was removed sl@0: # sl@0: test interp-1.6 {options for interp command} { sl@0: list [catch {interp slaves foo bar zop} msg] $msg sl@0: } {1 {wrong # args: should be "interp slaves ?path?"}} sl@0: test interp-1.7 {options for interp command} { sl@0: list [catch {interp hello} msg] $msg sl@0: } {1 {bad option "hello": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}} sl@0: test interp-1.8 {options for interp command} { sl@0: list [catch {interp -froboz} msg] $msg sl@0: } {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}} sl@0: test interp-1.9 {options for interp command} { sl@0: list [catch {interp -froboz -safe} msg] $msg sl@0: } {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}} sl@0: test interp-1.10 {options for interp command} { sl@0: list [catch {interp target} msg] $msg sl@0: } {1 {wrong # args: should be "interp target path alias"}} sl@0: sl@0: sl@0: # Part 1: Basic interpreter creation tests: sl@0: test interp-2.1 {basic interpreter creation} { sl@0: interp create a sl@0: } a sl@0: test interp-2.2 {basic interpreter creation} { sl@0: catch {interp create} sl@0: } 0 sl@0: test interp-2.3 {basic interpreter creation} { sl@0: catch {interp create -safe} sl@0: } 0 sl@0: test interp-2.4 {basic interpreter creation} { sl@0: list [catch {interp create a} msg] $msg sl@0: } {1 {interpreter named "a" already exists, cannot create}} sl@0: test interp-2.5 {basic interpreter creation} { sl@0: interp create b -safe sl@0: } b sl@0: test interp-2.6 {basic interpreter creation} { sl@0: interp create d -safe sl@0: } d sl@0: test interp-2.7 {basic interpreter creation} { sl@0: list [catch {interp create -froboz} msg] $msg sl@0: } {1 {bad option "-froboz": must be -safe or --}} sl@0: test interp-2.8 {basic interpreter creation} { sl@0: interp create -- -froboz sl@0: } -froboz sl@0: test interp-2.9 {basic interpreter creation} { sl@0: interp create -safe -- -froboz1 sl@0: } -froboz1 sl@0: test interp-2.10 {basic interpreter creation} { sl@0: interp create {a x1} sl@0: interp create {a x2} sl@0: interp create {a x3} -safe sl@0: } {a x3} sl@0: test interp-2.11 {anonymous interps vs existing procs} { sl@0: set x [interp create] sl@0: regexp "interp(\[0-9]+)" $x dummy thenum sl@0: interp delete $x sl@0: proc interp$thenum {} {} sl@0: set x [interp create] sl@0: regexp "interp(\[0-9]+)" $x dummy anothernum sl@0: expr $anothernum > $thenum sl@0: } 1 sl@0: test interp-2.12 {anonymous interps vs existing procs} { sl@0: set x [interp create -safe] sl@0: regexp "interp(\[0-9]+)" $x dummy thenum sl@0: interp delete $x sl@0: proc interp$thenum {} {} sl@0: set x [interp create -safe] sl@0: regexp "interp(\[0-9]+)" $x dummy anothernum sl@0: expr $anothernum - $thenum sl@0: } 1 sl@0: test interp-2.13 {correct default when no $path arg is given} -body { sl@0: interp create -- sl@0: } -match regexp -result {interp[0-9]+} sl@0: sl@0: foreach i [interp slaves] { sl@0: interp delete $i sl@0: } sl@0: sl@0: # Part 2: Testing "interp slaves" and "interp exists" sl@0: test interp-3.1 {testing interp exists and interp slaves} { sl@0: interp slaves sl@0: } "" sl@0: test interp-3.2 {testing interp exists and interp slaves} { sl@0: interp create a sl@0: interp exists a sl@0: } 1 sl@0: test interp-3.3 {testing interp exists and interp slaves} { sl@0: interp exists nonexistent sl@0: } 0 sl@0: test interp-3.4 {testing interp exists and interp slaves} { sl@0: list [catch {interp slaves a b c} msg] $msg sl@0: } {1 {wrong # args: should be "interp slaves ?path?"}} sl@0: test interp-3.5 {testing interp exists and interp slaves} { sl@0: list [catch {interp exists a b c} msg] $msg sl@0: } {1 {wrong # args: should be "interp exists ?path?"}} sl@0: test interp-3.6 {testing interp exists and interp slaves} { sl@0: interp exists sl@0: } 1 sl@0: test interp-3.7 {testing interp exists and interp slaves} { sl@0: interp slaves sl@0: } a sl@0: test interp-3.8 {testing interp exists and interp slaves} { sl@0: list [catch {interp slaves a b c} msg] $msg sl@0: } {1 {wrong # args: should be "interp slaves ?path?"}} sl@0: test interp-3.9 {testing interp exists and interp slaves} { sl@0: interp create {a a2} -safe sl@0: expr {[lsearch [interp slaves a] a2] >= 0} sl@0: } 1 sl@0: test interp-3.10 {testing interp exists and interp slaves} { sl@0: interp exists {a a2} sl@0: } 1 sl@0: sl@0: # Part 3: Testing "interp delete" sl@0: test interp-3.11 {testing interp delete} { sl@0: interp delete sl@0: } "" sl@0: test interp-4.1 {testing interp delete} { sl@0: catch {interp create a} sl@0: interp delete a sl@0: } "" sl@0: test interp-4.2 {testing interp delete} { sl@0: list [catch {interp delete nonexistent} msg] $msg sl@0: } {1 {could not find interpreter "nonexistent"}} sl@0: test interp-4.3 {testing interp delete} { sl@0: list [catch {interp delete x y z} msg] $msg sl@0: } {1 {could not find interpreter "x"}} sl@0: test interp-4.4 {testing interp delete} { sl@0: interp delete sl@0: } "" sl@0: test interp-4.5 {testing interp delete} { sl@0: interp create a sl@0: interp create {a x1} sl@0: interp delete {a x1} sl@0: expr {[lsearch [interp slaves a] x1] >= 0} sl@0: } 0 sl@0: test interp-4.6 {testing interp delete} { sl@0: interp create c1 sl@0: interp create c2 sl@0: interp create c3 sl@0: interp delete c1 c2 c3 sl@0: } "" sl@0: test interp-4.7 {testing interp delete} { sl@0: interp create c1 sl@0: interp create c2 sl@0: list [catch {interp delete c1 c2 c3} msg] $msg sl@0: } {1 {could not find interpreter "c3"}} sl@0: test interp-4.8 {testing interp delete} { sl@0: list [catch {interp delete {}} msg] $msg sl@0: } {1 {cannot delete the current interpreter}} sl@0: sl@0: foreach i [interp slaves] { sl@0: interp delete $i sl@0: } sl@0: sl@0: # Part 4: Consistency checking - all nondeleted interpreters should be sl@0: # there: sl@0: test interp-5.1 {testing consistency} { sl@0: interp slaves sl@0: } "" sl@0: test interp-5.2 {testing consistency} { sl@0: interp exists a sl@0: } 0 sl@0: test interp-5.3 {testing consistency} { sl@0: interp exists nonexistent sl@0: } 0 sl@0: sl@0: # Recreate interpreter "a" sl@0: interp create a sl@0: sl@0: # Part 5: Testing eval in interpreter object command and with interp command sl@0: test interp-6.1 {testing eval} { sl@0: a eval expr 3 + 5 sl@0: } 8 sl@0: test interp-6.2 {testing eval} { sl@0: list [catch {a eval foo} msg] $msg sl@0: } {1 {invalid command name "foo"}} sl@0: test interp-6.3 {testing eval} { sl@0: a eval {proc foo {} {expr 3 + 5}} sl@0: a eval foo sl@0: } 8 sl@0: test interp-6.4 {testing eval} { sl@0: interp eval a foo sl@0: } 8 sl@0: sl@0: test interp-6.5 {testing eval} { sl@0: interp create {a x2} sl@0: interp eval {a x2} {proc frob {} {expr 4 * 9}} sl@0: interp eval {a x2} frob sl@0: } 36 sl@0: test interp-6.6 {testing eval} { sl@0: list [catch {interp eval {a x2} foo} msg] $msg sl@0: } {1 {invalid command name "foo"}} sl@0: sl@0: # UTILITY PROCEDURE RUNNING IN MASTER INTERPRETER: sl@0: proc in_master {args} { sl@0: return [list seen in master: $args] sl@0: } sl@0: sl@0: # Part 6: Testing basic alias creation sl@0: test interp-7.1 {testing basic alias creation} { sl@0: a alias foo in_master sl@0: } foo sl@0: test interp-7.2 {testing basic alias creation} { sl@0: a alias bar in_master a1 a2 a3 sl@0: } bar sl@0: # Test 6.3 has been deleted. sl@0: test interp-7.3 {testing basic alias creation} { sl@0: a alias foo sl@0: } in_master sl@0: test interp-7.4 {testing basic alias creation} { sl@0: a alias bar sl@0: } {in_master a1 a2 a3} sl@0: test interp-7.5 {testing basic alias creation} { sl@0: lsort [a aliases] sl@0: } {bar foo} sl@0: test interp-7.6 {testing basic aliases arg checking} { sl@0: list [catch {a aliases too many args} msg] $msg sl@0: } {1 {wrong # args: should be "a aliases"}} sl@0: sl@0: # Part 7: testing basic alias invocation sl@0: test interp-8.1 {testing basic alias invocation} { sl@0: catch {interp create a} sl@0: a alias foo in_master sl@0: a eval foo s1 s2 s3 sl@0: } {seen in master: {s1 s2 s3}} sl@0: test interp-8.2 {testing basic alias invocation} { sl@0: catch {interp create a} sl@0: a alias bar in_master a1 a2 a3 sl@0: a eval bar s1 s2 s3 sl@0: } {seen in master: {a1 a2 a3 s1 s2 s3}} sl@0: test interp-8.3 {testing basic alias invocation} { sl@0: catch {interp create a} sl@0: list [catch {a alias} msg] $msg sl@0: } {1 {wrong # args: should be "a alias aliasName ?targetName? ?args..?"}} sl@0: sl@0: # Part 8: Testing aliases for non-existent or hidden targets sl@0: test interp-9.1 {testing aliases for non-existent targets} { sl@0: catch {interp create a} sl@0: a alias zop nonexistent-command-in-master sl@0: list [catch {a eval zop} msg] $msg sl@0: } {1 {invalid command name "nonexistent-command-in-master"}} sl@0: test interp-9.2 {testing aliases for non-existent targets} { sl@0: catch {interp create a} sl@0: a alias zop nonexistent-command-in-master sl@0: proc nonexistent-command-in-master {} {return i_exist!} sl@0: a eval zop sl@0: } i_exist! sl@0: test interp-9.3 {testing aliases for hidden commands} { sl@0: catch {interp create a} sl@0: a eval {proc p {} {return ENTER_A}} sl@0: interp alias {} p a p sl@0: set res {} sl@0: lappend res [list [catch p msg] $msg] sl@0: interp hide a p sl@0: lappend res [list [catch p msg] $msg] sl@0: rename p {} sl@0: interp delete a sl@0: set res sl@0: } {{0 ENTER_A} {1 {invalid command name "p"}}} sl@0: test interp-9.4 {testing aliases and namespace commands} { sl@0: proc p {} {return GLOBAL} sl@0: namespace eval tst { sl@0: proc p {} {return NAMESPACE} sl@0: } sl@0: interp alias {} a {} p sl@0: set res [a] sl@0: lappend res [namespace eval tst a] sl@0: rename p {} sl@0: rename a {} sl@0: namespace delete tst sl@0: set res sl@0: } {GLOBAL GLOBAL} sl@0: sl@0: if {[info command nonexistent-command-in-master] != ""} { sl@0: rename nonexistent-command-in-master {} sl@0: } sl@0: sl@0: # Part 9: Aliasing between interpreters sl@0: test interp-10.1 {testing aliasing between interpreters} { sl@0: catch {interp delete a} sl@0: catch {interp delete b} sl@0: interp create a sl@0: interp create b sl@0: interp alias a a_alias b b_alias 1 2 3 sl@0: } a_alias sl@0: test interp-10.2 {testing aliasing between interpreters} { sl@0: catch {interp delete a} sl@0: catch {interp delete b} sl@0: interp create a sl@0: interp create b sl@0: b eval {proc b_alias {args} {return [list got $args]}} sl@0: interp alias a a_alias b b_alias 1 2 3 sl@0: a eval a_alias a b c sl@0: } {got {1 2 3 a b c}} sl@0: test interp-10.3 {testing aliasing between interpreters} { sl@0: catch {interp delete a} sl@0: catch {interp delete b} sl@0: interp create a sl@0: interp create b sl@0: interp alias a a_alias b b_alias 1 2 3 sl@0: list [catch {a eval a_alias a b c} msg] $msg sl@0: } {1 {invalid command name "b_alias"}} sl@0: test interp-10.4 {testing aliasing between interpreters} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a alias a_alias puts sl@0: a aliases sl@0: } a_alias sl@0: test interp-10.5 {testing aliasing between interpreters} { sl@0: catch {interp delete a} sl@0: catch {interp delete b} sl@0: interp create a sl@0: interp create b sl@0: a alias a_alias puts sl@0: interp alias a a_del b b_del sl@0: interp delete b sl@0: a aliases sl@0: } a_alias sl@0: test interp-10.6 {testing aliasing between interpreters} { sl@0: catch {interp delete a} sl@0: catch {interp delete b} sl@0: interp create a sl@0: interp create b sl@0: interp alias a a_command b b_command a1 a2 a3 sl@0: b alias b_command in_master b1 b2 b3 sl@0: a eval a_command m1 m2 m3 sl@0: } {seen in master: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} sl@0: test interp-10.7 {testing aliases between interpreters} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp alias "" foo a zoppo sl@0: a eval {proc zoppo {x} {list $x $x $x}} sl@0: set x [foo 33] sl@0: a eval {rename zoppo {}} sl@0: interp alias "" foo a {} sl@0: equiv $x sl@0: } {33 33 33} sl@0: sl@0: # Part 10: Testing "interp target" sl@0: test interp-11.1 {testing interp target} { sl@0: list [catch {interp target} msg] $msg sl@0: } {1 {wrong # args: should be "interp target path alias"}} sl@0: test interp-11.2 {testing interp target} { sl@0: list [catch {interp target nosuchinterpreter foo} msg] $msg sl@0: } {1 {could not find interpreter "nosuchinterpreter"}} sl@0: test interp-11.3 {testing interp target} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a alias boo no_command sl@0: interp target a boo sl@0: } "" sl@0: test interp-11.4 {testing interp target} { sl@0: catch {interp delete x1} sl@0: interp create x1 sl@0: x1 eval interp create x2 sl@0: x1 eval x2 eval interp create x3 sl@0: catch {interp delete y1} sl@0: interp create y1 sl@0: y1 eval interp create y2 sl@0: y1 eval y2 eval interp create y3 sl@0: interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand sl@0: interp target {x1 x2 x3} xcommand sl@0: } {y1 y2 y3} sl@0: test interp-11.5 {testing interp target} { sl@0: catch {interp delete x1} sl@0: interp create x1 sl@0: interp create {x1 x2} sl@0: interp create {x1 x2 x3} sl@0: catch {interp delete y1} sl@0: interp create y1 sl@0: interp create {y1 y2} sl@0: interp create {y1 y2 y3} sl@0: interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand sl@0: list [catch {x1 eval {interp target {x2 x3} xcommand}} msg] $msg sl@0: } {1 {target interpreter for alias "xcommand" in path "x2 x3" is not my descendant}} sl@0: test interp-11.6 {testing interp target} { sl@0: foreach a [interp aliases] { sl@0: rename $a {} sl@0: } sl@0: list [catch {interp target {} foo} msg] $msg sl@0: } {1 {alias "foo" in path "" not found}} sl@0: test interp-11.7 {testing interp target} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: list [catch {interp target a foo} msg] $msg sl@0: } {1 {alias "foo" in path "a" not found}} sl@0: sl@0: # Part 11: testing "interp issafe" sl@0: test interp-12.1 {testing interp issafe} { sl@0: interp issafe sl@0: } 0 sl@0: test interp-12.2 {testing interp issafe} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp issafe a sl@0: } 0 sl@0: test interp-12.3 {testing interp issafe} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp create {a x3} -safe sl@0: interp issafe {a x3} sl@0: } 1 sl@0: test interp-12.4 {testing interp issafe} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp create {a x3} -safe sl@0: interp create {a x3 foo} sl@0: interp issafe {a x3 foo} sl@0: } 1 sl@0: sl@0: # Part 12: testing interpreter object command "issafe" sub-command sl@0: test interp-13.1 {testing foo issafe} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a issafe sl@0: } 0 sl@0: test interp-13.2 {testing foo issafe} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp create {a x3} -safe sl@0: a eval x3 issafe sl@0: } 1 sl@0: test interp-13.3 {testing foo issafe} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp create {a x3} -safe sl@0: interp create {a x3 foo} sl@0: a eval x3 eval foo issafe sl@0: } 1 sl@0: test interp-13.4 {testing issafe arg checking} { sl@0: catch {interp create a} sl@0: list [catch {a issafe too many args} msg] $msg sl@0: } {1 {wrong # args: should be "a issafe"}} sl@0: sl@0: # part 14: testing interp aliases sl@0: test interp-14.1 {testing interp aliases} { sl@0: interp aliases sl@0: } "" sl@0: test interp-14.2 {testing interp aliases} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a alias a1 puts sl@0: a alias a2 puts sl@0: a alias a3 puts sl@0: lsort [interp aliases a] sl@0: } {a1 a2 a3} sl@0: test interp-14.3 {testing interp aliases} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp create {a x3} sl@0: interp alias {a x3} froboz "" puts sl@0: interp aliases {a x3} sl@0: } froboz sl@0: test interp-14.4 {testing interp alias - alias over master} { sl@0: # SF Bug 641195 sl@0: catch {interp delete a} sl@0: interp create a sl@0: list [catch {interp alias "" a a eval} msg] $msg [info commands a] sl@0: } {1 {cannot define or rename alias "a": interpreter deleted} {}} sl@0: sl@0: # part 15: testing file sharing sl@0: test interp-15.1 {testing file sharing} { sl@0: catch {interp delete z} sl@0: interp create z sl@0: z eval close stdout sl@0: list [catch {z eval puts hello} msg] $msg sl@0: } {1 {can not find channel named "stdout"}} sl@0: test interp-15.2 {testing file sharing} -body { sl@0: catch {interp delete z} sl@0: interp create z sl@0: set f [open [makeFile {} file-15.2] w] sl@0: interp share "" $f z sl@0: z eval puts $f hello sl@0: z eval close $f sl@0: close $f sl@0: } -cleanup { sl@0: removeFile file-15.2 sl@0: } -result "" sl@0: test interp-15.3 {testing file sharing} { sl@0: catch {interp delete xsafe} sl@0: interp create xsafe -safe sl@0: list [catch {xsafe eval puts hello} msg] $msg sl@0: } {1 {can not find channel named "stdout"}} sl@0: test interp-15.4 {testing file sharing} -body { sl@0: catch {interp delete xsafe} sl@0: interp create xsafe -safe sl@0: set f [open [makeFile {} file-15.4] w] sl@0: interp share "" $f xsafe sl@0: xsafe eval puts $f hello sl@0: xsafe eval close $f sl@0: close $f sl@0: } -cleanup { sl@0: removeFile file-15.4 sl@0: } -result "" sl@0: test interp-15.5 {testing file sharing} { sl@0: catch {interp delete xsafe} sl@0: interp create xsafe -safe sl@0: interp share "" stdout xsafe sl@0: list [catch {xsafe eval gets stdout} msg] $msg sl@0: } {1 {channel "stdout" wasn't opened for reading}} sl@0: test interp-15.6 {testing file sharing} -body { sl@0: catch {interp delete xsafe} sl@0: interp create xsafe -safe sl@0: set f [open [makeFile {} file-15.6] w] sl@0: interp share "" $f xsafe sl@0: set x [list [catch [list xsafe eval gets $f] msg] $msg] sl@0: xsafe eval close $f sl@0: close $f sl@0: string compare [string tolower $x] \ sl@0: [list 1 [format "channel \"%s\" wasn't opened for reading" $f]] sl@0: } -cleanup { sl@0: removeFile file-15.6 sl@0: } -result 0 sl@0: test interp-15.7 {testing file transferring} -body { sl@0: catch {interp delete xsafe} sl@0: interp create xsafe -safe sl@0: set f [open [makeFile {} file-15.7] w] sl@0: interp transfer "" $f xsafe sl@0: xsafe eval puts $f hello sl@0: xsafe eval close $f sl@0: } -cleanup { sl@0: removeFile file-15.7 sl@0: } -result "" sl@0: test interp-15.8 {testing file transferring} -body { sl@0: catch {interp delete xsafe} sl@0: interp create xsafe -safe sl@0: set f [open [makeFile {} file-15.8] w] sl@0: interp transfer "" $f xsafe sl@0: xsafe eval close $f sl@0: set x [list [catch {close $f} msg] $msg] sl@0: string compare [string tolower $x] \ sl@0: [list 1 [format "can not find channel named \"%s\"" $f]] sl@0: } -cleanup { sl@0: removeFile file-15.8 sl@0: } -result 0 sl@0: sl@0: # sl@0: # Torture tests for interpreter deletion order sl@0: # sl@0: proc kill {} {interp delete xxx} sl@0: sl@0: test interp-15.9 {testing deletion order} { sl@0: catch {interp delete xxx} sl@0: interp create xxx sl@0: xxx alias kill kill sl@0: list [catch {xxx eval kill} msg] $msg sl@0: } {0 {}} sl@0: test interp-16.1 {testing deletion order} { sl@0: catch {interp delete xxx} sl@0: interp create xxx sl@0: interp create {xxx yyy} sl@0: interp alias {xxx yyy} kill "" kill sl@0: list [catch {interp eval {xxx yyy} kill} msg] $msg sl@0: } {0 {}} sl@0: test interp-16.2 {testing deletion order} { sl@0: catch {interp delete xxx} sl@0: interp create xxx sl@0: interp create {xxx yyy} sl@0: interp alias {xxx yyy} kill "" kill sl@0: list [catch {xxx eval yyy eval kill} msg] $msg sl@0: } {0 {}} sl@0: test interp-16.3 {testing deletion order} { sl@0: catch {interp delete xxx} sl@0: interp create xxx sl@0: interp create ddd sl@0: xxx alias kill kill sl@0: interp alias ddd kill xxx kill sl@0: set x [ddd eval kill] sl@0: interp delete ddd sl@0: set x sl@0: } "" sl@0: test interp-16.4 {testing deletion order} { sl@0: catch {interp delete xxx} sl@0: interp create xxx sl@0: interp create {xxx yyy} sl@0: interp alias {xxx yyy} kill "" kill sl@0: interp create ddd sl@0: interp alias ddd kill {xxx yyy} kill sl@0: set x [ddd eval kill] sl@0: interp delete ddd sl@0: set x sl@0: } "" sl@0: test interp-16.5 {testing deletion order, bgerror} { sl@0: catch {interp delete xxx} sl@0: interp create xxx sl@0: xxx eval {proc bgerror {args} {exit}} sl@0: xxx alias exit kill xxx sl@0: proc kill {i} {interp delete $i} sl@0: xxx eval after 100 expr a + b sl@0: after 200 sl@0: update sl@0: interp exists xxx sl@0: } 0 sl@0: sl@0: # sl@0: # Alias loop prevention testing. sl@0: # sl@0: sl@0: test interp-17.1 {alias loop prevention} { sl@0: list [catch {interp alias {} a {} a} msg] $msg sl@0: } {1 {cannot define or rename alias "a": would create a loop}} sl@0: test interp-17.2 {alias loop prevention} { sl@0: catch {interp delete x} sl@0: interp create x sl@0: x alias a loop sl@0: list [catch {interp alias {} loop x a} msg] $msg sl@0: } {1 {cannot define or rename alias "loop": would create a loop}} sl@0: test interp-17.3 {alias loop prevention} { sl@0: catch {interp delete x} sl@0: interp create x sl@0: interp alias x a x b sl@0: list [catch {interp alias x b x a} msg] $msg sl@0: } {1 {cannot define or rename alias "b": would create a loop}} sl@0: test interp-17.4 {alias loop prevention} { sl@0: catch {interp delete x} sl@0: interp create x sl@0: interp alias x b x a sl@0: list [catch {x eval rename b a} msg] $msg sl@0: } {1 {cannot define or rename alias "b": would create a loop}} sl@0: test interp-17.5 {alias loop prevention} { sl@0: catch {interp delete x} sl@0: interp create x sl@0: x alias z l1 sl@0: interp alias {} l2 x z sl@0: list [catch {rename l2 l1} msg] $msg sl@0: } {1 {cannot define or rename alias "l2": would create a loop}} sl@0: sl@0: # sl@0: # Test robustness of Tcl_DeleteInterp when applied to a slave interpreter. sl@0: # If there are bugs in the implementation these tests are likely to expose sl@0: # the bugs as a core dump. sl@0: # sl@0: sl@0: if {[info commands testinterpdelete] == ""} { sl@0: puts "This application hasn't been compiled with the \"testinterpdelete\"" sl@0: puts "command, so I can't test slave delete calls" sl@0: } else { sl@0: test interp-18.1 {testing Tcl_DeleteInterp vs slaves} { sl@0: list [catch {testinterpdelete} msg] $msg sl@0: } {1 {wrong # args: should be "testinterpdelete path"}} sl@0: test interp-18.2 {testing Tcl_DeleteInterp vs slaves} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: testinterpdelete a sl@0: } "" sl@0: test interp-18.3 {testing Tcl_DeleteInterp vs slaves} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp create {a b} sl@0: testinterpdelete {a b} sl@0: } "" sl@0: test interp-18.4 {testing Tcl_DeleteInterp vs slaves} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp create {a b} sl@0: testinterpdelete a sl@0: } "" sl@0: test interp-18.5 {testing Tcl_DeleteInterp vs slaves} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp create {a b} sl@0: interp alias {a b} dodel {} dodel sl@0: proc dodel {x} {testinterpdelete $x} sl@0: list [catch {interp eval {a b} {dodel {a b}}} msg] $msg sl@0: } {0 {}} sl@0: test interp-18.6 {testing Tcl_DeleteInterp vs slaves} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp create {a b} sl@0: interp alias {a b} dodel {} dodel sl@0: proc dodel {x} {testinterpdelete $x} sl@0: list [catch {interp eval {a b} {dodel a}} msg] $msg sl@0: } {0 {}} sl@0: test interp-18.7 {eval in deleted interp} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval { sl@0: proc dodel {} { sl@0: delme sl@0: dosomething else sl@0: } sl@0: proc dosomething args { sl@0: puts "I should not have been called!!" sl@0: } sl@0: } sl@0: a alias delme dela sl@0: proc dela {} {interp delete a} sl@0: list [catch {a eval dodel} msg] $msg sl@0: } {1 {attempt to call eval in deleted interpreter}} sl@0: test interp-18.8 {eval in deleted interp} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval { sl@0: interp create b sl@0: b eval { sl@0: proc dodel {} { sl@0: dela sl@0: } sl@0: } sl@0: proc foo {} { sl@0: b eval dela sl@0: dosomething else sl@0: } sl@0: proc dosomething args { sl@0: puts "I should not have been called!!" sl@0: } sl@0: } sl@0: interp alias {a b} dela {} dela sl@0: proc dela {} {interp delete a} sl@0: list [catch {a eval foo} msg] $msg sl@0: } {1 {attempt to call eval in deleted interpreter}} sl@0: } sl@0: test interp-18.9 {eval in deleted interp, bug 495830} {knownBug} { sl@0: interp create tst sl@0: interp alias tst suicide {} interp delete tst sl@0: list [catch {tst eval {suicide; set a 5}} msg] $msg sl@0: } {1 {attempt to call eval in deleted interpreter}} sl@0: test interp-18.10 {eval in deleted interp, bug 495830} { sl@0: interp create tst sl@0: interp alias tst suicide {} interp delete tst sl@0: list [catch {tst eval {set set set; suicide; $set a 5}} msg] $msg sl@0: } {1 {attempt to call eval in deleted interpreter}} sl@0: sl@0: # Test alias deletion sl@0: sl@0: test interp-19.1 {alias deletion} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp alias a foo a bar sl@0: set s [interp alias a foo {}] sl@0: interp delete a sl@0: set s sl@0: } {} sl@0: test interp-19.2 {alias deletion} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: catch {interp alias a foo {}} msg sl@0: interp delete a sl@0: set msg sl@0: } {alias "foo" not found} sl@0: test interp-19.3 {alias deletion} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp alias a foo a bar sl@0: interp eval a {rename foo zop} sl@0: interp alias a foo a zop sl@0: catch {interp eval a foo} msg sl@0: interp delete a sl@0: set msg sl@0: } {invalid command name "zop"} sl@0: test interp-19.4 {alias deletion} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp alias a foo a bar sl@0: interp eval a {rename foo zop} sl@0: catch {interp eval a foo} msg sl@0: interp delete a sl@0: set msg sl@0: } {invalid command name "foo"} sl@0: test interp-19.5 {alias deletion} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp eval a {proc bar {} {return 1}} sl@0: interp alias a foo a bar sl@0: interp eval a {rename foo zop} sl@0: catch {interp eval a zop} msg sl@0: interp delete a sl@0: set msg sl@0: } 1 sl@0: test interp-19.6 {alias deletion} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp alias a foo a bar sl@0: interp eval a {rename foo zop} sl@0: interp alias a foo a zop sl@0: set s [interp aliases a] sl@0: interp delete a sl@0: set s sl@0: } foo sl@0: test interp-19.7 {alias deletion, renaming} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp alias a foo a bar sl@0: interp eval a rename foo blotz sl@0: interp alias a foo {} sl@0: set s [interp aliases a] sl@0: interp delete a sl@0: set s sl@0: } {} sl@0: test interp-19.8 {alias deletion, renaming} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp alias a foo a bar sl@0: interp eval a rename foo blotz sl@0: set l "" sl@0: lappend l [interp aliases a] sl@0: interp alias a foo {} sl@0: lappend l [interp aliases a] sl@0: interp delete a sl@0: set l sl@0: } {foo {}} sl@0: test interp-19.9 {alias deletion, renaming} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp alias a foo a bar sl@0: interp eval a rename foo blotz sl@0: interp eval a {proc foo {} {expr 34 * 34}} sl@0: interp alias a foo {} sl@0: set l [interp eval a foo] sl@0: interp delete a sl@0: set l sl@0: } 1156 sl@0: sl@0: test interp-20.1 {interp hide, interp expose and interp invokehidden} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval {proc unknown {x args} {error "invalid command name \"$x\""}} sl@0: a eval {proc foo {} {}} sl@0: a hide foo sl@0: catch {a eval foo something} msg sl@0: interp delete a sl@0: set msg sl@0: } {invalid command name "foo"} sl@0: test interp-20.2 {interp hide, interp expose and interp invokehidden} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval {proc unknown {x args} {error "invalid command name \"$x\""}} sl@0: a hide list sl@0: set l "" sl@0: lappend l [catch {a eval {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: a expose list sl@0: lappend l [catch {a eval {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {invalid command name "list"} 0 {1 2 3}} sl@0: test interp-20.3 {interp hide, interp expose and interp invokehidden} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval {proc unknown {x args} {error "invalid command name \"$x\""}} sl@0: a hide list sl@0: set l "" sl@0: lappend l [catch {a eval {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: lappend l [catch {a invokehidden list 1 2 3} msg] sl@0: lappend l $msg sl@0: a expose list sl@0: lappend l [catch {a eval {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}} sl@0: test interp-20.4 {interp hide, interp expose and interp invokehidden -- passing {}} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval {proc unknown {x args} {error "invalid command name \"$x\""}} sl@0: a hide list sl@0: set l "" sl@0: lappend l [catch {a eval {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: lappend l [catch {a invokehidden list {"" 1 2 3}} msg] sl@0: lappend l $msg sl@0: a expose list sl@0: lappend l [catch {a eval {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}} sl@0: test interp-20.5 {interp hide, interp expose and interp invokehidden -- passing {}} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval {proc unknown {x args} {error "invalid command name \"$x\""}} sl@0: a hide list sl@0: set l "" sl@0: lappend l [catch {a eval {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: lappend l [catch {a invokehidden list {{} 1 2 3}} msg] sl@0: lappend l $msg sl@0: a expose list sl@0: lappend l [catch {a eval {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}} sl@0: test interp-20.6 {interp invokehidden -- eval args} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a hide list sl@0: set l "" sl@0: set z 45 sl@0: lappend l [catch {a invokehidden list $z 1 2 3} msg] sl@0: lappend l $msg sl@0: a expose list sl@0: lappend l [catch {a eval list $z 1 2 3} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {45 1 2 3} 0 {45 1 2 3}} sl@0: test interp-20.7 {interp invokehidden vs variable eval} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a hide list sl@0: set z 45 sl@0: set l "" sl@0: lappend l [catch {a invokehidden list {$z a b c}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {{$z a b c}}} sl@0: test interp-20.8 {interp invokehidden vs variable eval} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a hide list sl@0: a eval set z 89 sl@0: set z 45 sl@0: set l "" sl@0: lappend l [catch {a invokehidden list {$z a b c}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {{$z a b c}}} sl@0: test interp-20.9 {interp invokehidden vs variable eval} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a hide list sl@0: a eval set z 89 sl@0: set z 45 sl@0: set l "" sl@0: lappend l [catch {a invokehidden list $z {$z a b c}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {45 {$z a b c}}} sl@0: test interp-20.10 {interp hide, interp expose and interp invokehidden} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval {proc unknown {x args} {error "invalid command name \"$x\""}} sl@0: a eval {proc foo {} {}} sl@0: interp hide a foo sl@0: catch {interp eval a foo something} msg sl@0: interp delete a sl@0: set msg sl@0: } {invalid command name "foo"} sl@0: test interp-20.11 {interp hide, interp expose and interp invokehidden} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval {proc unknown {x args} {error "invalid command name \"$x\""}} sl@0: interp hide a list sl@0: set l "" sl@0: lappend l [catch {interp eval a {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: interp expose a list sl@0: lappend l [catch {interp eval a {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {invalid command name "list"} 0 {1 2 3}} sl@0: test interp-20.12 {interp hide, interp expose and interp invokehidden} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval {proc unknown {x args} {error "invalid command name \"$x\""}} sl@0: interp hide a list sl@0: set l "" sl@0: lappend l [catch {interp eval a {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: lappend l [catch {interp invokehidden a list 1 2 3} msg] sl@0: lappend l $msg sl@0: interp expose a list sl@0: lappend l [catch {interp eval a {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}} sl@0: test interp-20.13 {interp hide, interp expose, interp invokehidden -- passing {}} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval {proc unknown {x args} {error "invalid command name \"$x\""}} sl@0: interp hide a list sl@0: set l "" sl@0: lappend l [catch {interp eval a {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: lappend l [catch {interp invokehidden a list {"" 1 2 3}} msg] sl@0: lappend l $msg sl@0: interp expose a list sl@0: lappend l [catch {interp eval a {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}} sl@0: test interp-20.14 {interp hide, interp expose, interp invokehidden -- passing {}} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval {proc unknown {x args} {error "invalid command name \"$x\""}} sl@0: interp hide a list sl@0: set l "" sl@0: lappend l [catch {interp eval a {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: lappend l [catch {interp invokehidden a list {{} 1 2 3}} msg] sl@0: lappend l $msg sl@0: interp expose a list sl@0: lappend l [catch {a eval {list 1 2 3}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}} sl@0: test interp-20.15 {interp invokehidden -- eval args} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp hide a list sl@0: set l "" sl@0: set z 45 sl@0: lappend l [catch {interp invokehidden a list $z 1 2 3} msg] sl@0: lappend l $msg sl@0: a expose list sl@0: lappend l [catch {interp eval a list $z 1 2 3} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {45 1 2 3} 0 {45 1 2 3}} sl@0: test interp-20.16 {interp invokehidden vs variable eval} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp hide a list sl@0: set z 45 sl@0: set l "" sl@0: lappend l [catch {interp invokehidden a list {$z a b c}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {{$z a b c}}} sl@0: test interp-20.17 {interp invokehidden vs variable eval} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp hide a list sl@0: a eval set z 89 sl@0: set z 45 sl@0: set l "" sl@0: lappend l [catch {interp invokehidden a list {$z a b c}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {{$z a b c}}} sl@0: test interp-20.18 {interp invokehidden vs variable eval} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp hide a list sl@0: a eval set z 89 sl@0: set z 45 sl@0: set l "" sl@0: lappend l [catch {interp invokehidden a list $z {$z a b c}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {45 {$z a b c}}} sl@0: test interp-20.19 {interp invokehidden vs nested commands} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a hide list sl@0: set l [a invokehidden list {[list x y z] f g h} z] sl@0: interp delete a sl@0: set l sl@0: } {{[list x y z] f g h} z} sl@0: test interp-20.20 {interp invokehidden vs nested commands} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a hide list sl@0: set l [interp invokehidden a list {[list x y z] f g h} z] sl@0: interp delete a sl@0: set l sl@0: } {{[list x y z] f g h} z} sl@0: test interp-20.21 {interp hide vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [catch {a hide list} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {}} sl@0: test interp-20.22 {interp hide vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [catch {interp hide a list} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {}} sl@0: test interp-20.23 {interp hide vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [catch {a eval {interp hide {} list}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {permission denied: safe interpreter cannot hide commands}} sl@0: test interp-20.24 {interp hide vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: interp create {a b} sl@0: set l "" sl@0: lappend l [catch {a eval {interp hide b list}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {permission denied: safe interpreter cannot hide commands}} sl@0: test interp-20.25 {interp hide vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: interp create {a b} sl@0: set l "" sl@0: lappend l [catch {interp hide {a b} list} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {}} sl@0: test interp-20.26 {interp expoose vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [catch {a hide list} msg] sl@0: lappend l $msg sl@0: lappend l [catch {a expose list} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {} 0 {}} sl@0: test interp-20.27 {interp expose vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [catch {interp hide a list} msg] sl@0: lappend l $msg sl@0: lappend l [catch {interp expose a list} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {} 0 {}} sl@0: test interp-20.28 {interp expose vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [catch {a hide list} msg] sl@0: lappend l $msg sl@0: lappend l [catch {a eval {interp expose {} list}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {} 1 {permission denied: safe interpreter cannot expose commands}} sl@0: test interp-20.29 {interp expose vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [catch {interp hide a list} msg] sl@0: lappend l $msg sl@0: lappend l [catch {a eval {interp expose {} list}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {} 1 {permission denied: safe interpreter cannot expose commands}} sl@0: test interp-20.30 {interp expose vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: interp create {a b} sl@0: set l "" sl@0: lappend l [catch {interp hide {a b} list} msg] sl@0: lappend l $msg sl@0: lappend l [catch {a eval {interp expose b list}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {} 1 {permission denied: safe interpreter cannot expose commands}} sl@0: test interp-20.31 {interp expose vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: interp create {a b} sl@0: set l "" sl@0: lappend l [catch {interp hide {a b} list} msg] sl@0: lappend l $msg sl@0: lappend l [catch {interp expose {a b} list} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {0 {} 0 {}} sl@0: test interp-20.32 {interp invokehidden vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: interp hide a list sl@0: set l "" sl@0: lappend l [catch {a eval {interp invokehidden {} list a b c}} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {not allowed to invoke hidden commands from safe interpreter}} sl@0: test interp-20.33 {interp invokehidden vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: interp hide a list sl@0: set l "" sl@0: lappend l [catch {a eval {interp invokehidden {} list a b c}} msg] sl@0: lappend l $msg sl@0: lappend l [catch {a invokehidden list a b c} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {not allowed to invoke hidden commands from safe interpreter}\ sl@0: 0 {a b c}} sl@0: test interp-20.34 {interp invokehidden vs safety} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: interp create {a b} sl@0: interp hide {a b} list sl@0: set l "" sl@0: lappend l [catch {a eval {interp invokehidden b list a b c}} msg] sl@0: lappend l $msg sl@0: lappend l [catch {interp invokehidden {a b} list a b c} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {not allowed to invoke hidden commands from safe interpreter}\ sl@0: 0 {a b c}} sl@0: test interp-20.35 {invokehidden at local level} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval { sl@0: proc p1 {} { sl@0: set z 90 sl@0: a1 sl@0: set z sl@0: } sl@0: proc h1 {} { sl@0: upvar z z sl@0: set z 91 sl@0: } sl@0: } sl@0: a hide h1 sl@0: a alias a1 a1 sl@0: proc a1 {} { sl@0: interp invokehidden a h1 sl@0: } sl@0: set r [interp eval a p1] sl@0: interp delete a sl@0: set r sl@0: } 91 sl@0: test interp-20.36 {invokehidden at local level} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval { sl@0: set z 90 sl@0: proc p1 {} { sl@0: global z sl@0: a1 sl@0: set z sl@0: } sl@0: proc h1 {} { sl@0: upvar z z sl@0: set z 91 sl@0: } sl@0: } sl@0: a hide h1 sl@0: a alias a1 a1 sl@0: proc a1 {} { sl@0: interp invokehidden a h1 sl@0: } sl@0: set r [interp eval a p1] sl@0: interp delete a sl@0: set r sl@0: } 91 sl@0: test interp-20.37 {invokehidden at local level} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval { sl@0: proc p1 {} { sl@0: a1 sl@0: set z sl@0: } sl@0: proc h1 {} { sl@0: upvar z z sl@0: set z 91 sl@0: } sl@0: } sl@0: a hide h1 sl@0: a alias a1 a1 sl@0: proc a1 {} { sl@0: interp invokehidden a h1 sl@0: } sl@0: set r [interp eval a p1] sl@0: interp delete a sl@0: set r sl@0: } 91 sl@0: test interp-20.38 {invokehidden at global level} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval { sl@0: proc p1 {} { sl@0: a1 sl@0: set z sl@0: } sl@0: proc h1 {} { sl@0: upvar z z sl@0: set z 91 sl@0: } sl@0: } sl@0: a hide h1 sl@0: a alias a1 a1 sl@0: proc a1 {} { sl@0: interp invokehidden a -global h1 sl@0: } sl@0: set r [catch {interp eval a p1} msg] sl@0: interp delete a sl@0: list $r $msg sl@0: } {1 {can't read "z": no such variable}} sl@0: test interp-20.39 {invokehidden at global level} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval { sl@0: proc p1 {} { sl@0: global z sl@0: a1 sl@0: set z sl@0: } sl@0: proc h1 {} { sl@0: upvar z z sl@0: set z 91 sl@0: } sl@0: } sl@0: a hide h1 sl@0: a alias a1 a1 sl@0: proc a1 {} { sl@0: interp invokehidden a -global h1 sl@0: } sl@0: set r [catch {interp eval a p1} msg] sl@0: interp delete a sl@0: list $r $msg sl@0: } {0 91} sl@0: test interp-20.40 {safe, invokehidden at local level} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: a eval { sl@0: proc p1 {} { sl@0: set z 90 sl@0: a1 sl@0: set z sl@0: } sl@0: proc h1 {} { sl@0: upvar z z sl@0: set z 91 sl@0: } sl@0: } sl@0: a hide h1 sl@0: a alias a1 a1 sl@0: proc a1 {} { sl@0: interp invokehidden a h1 sl@0: } sl@0: set r [interp eval a p1] sl@0: interp delete a sl@0: set r sl@0: } 91 sl@0: test interp-20.41 {safe, invokehidden at local level} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: a eval { sl@0: set z 90 sl@0: proc p1 {} { sl@0: global z sl@0: a1 sl@0: set z sl@0: } sl@0: proc h1 {} { sl@0: upvar z z sl@0: set z 91 sl@0: } sl@0: } sl@0: a hide h1 sl@0: a alias a1 a1 sl@0: proc a1 {} { sl@0: interp invokehidden a h1 sl@0: } sl@0: set r [interp eval a p1] sl@0: interp delete a sl@0: set r sl@0: } 91 sl@0: test interp-20.42 {safe, invokehidden at local level} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: a eval { sl@0: proc p1 {} { sl@0: a1 sl@0: set z sl@0: } sl@0: proc h1 {} { sl@0: upvar z z sl@0: set z 91 sl@0: } sl@0: } sl@0: a hide h1 sl@0: a alias a1 a1 sl@0: proc a1 {} { sl@0: interp invokehidden a h1 sl@0: } sl@0: set r [interp eval a p1] sl@0: interp delete a sl@0: set r sl@0: } 91 sl@0: test interp-20.43 {invokehidden at global level} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval { sl@0: proc p1 {} { sl@0: a1 sl@0: set z sl@0: } sl@0: proc h1 {} { sl@0: upvar z z sl@0: set z 91 sl@0: } sl@0: } sl@0: a hide h1 sl@0: a alias a1 a1 sl@0: proc a1 {} { sl@0: interp invokehidden a -global h1 sl@0: } sl@0: set r [catch {interp eval a p1} msg] sl@0: interp delete a sl@0: list $r $msg sl@0: } {1 {can't read "z": no such variable}} sl@0: test interp-20.44 {invokehidden at global level} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval { sl@0: proc p1 {} { sl@0: global z sl@0: a1 sl@0: set z sl@0: } sl@0: proc h1 {} { sl@0: upvar z z sl@0: set z 91 sl@0: } sl@0: } sl@0: a hide h1 sl@0: a alias a1 a1 sl@0: proc a1 {} { sl@0: interp invokehidden a -global h1 sl@0: } sl@0: set r [catch {interp eval a p1} msg] sl@0: interp delete a sl@0: list $r $msg sl@0: } {0 91} sl@0: test interp-20.45 {interp hide vs namespaces} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval { sl@0: namespace eval foo {} sl@0: proc foo::x {} {} sl@0: } sl@0: set l [list [catch {interp hide a foo::x} msg] $msg] sl@0: interp delete a sl@0: set l sl@0: } {1 {cannot use namespace qualifiers in hidden command token (rename)}} sl@0: test interp-20.46 {interp hide vs namespaces} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval { sl@0: namespace eval foo {} sl@0: proc foo::x {} {} sl@0: } sl@0: set l [list [catch {interp hide a foo::x x} msg] $msg] sl@0: interp delete a sl@0: set l sl@0: } {1 {can only hide global namespace commands (use rename then hide)}} sl@0: test interp-20.47 {interp hide vs namespaces} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval { sl@0: proc x {} {} sl@0: } sl@0: set l [list [catch {interp hide a x foo::x} msg] $msg] sl@0: interp delete a sl@0: set l sl@0: } {1 {cannot use namespace qualifiers in hidden command token (rename)}} sl@0: test interp-20.48 {interp hide vs namespaces} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a eval { sl@0: namespace eval foo {} sl@0: proc foo::x {} {} sl@0: } sl@0: set l [list [catch {interp hide a foo::x bar::x} msg] $msg] sl@0: interp delete a sl@0: set l sl@0: } {1 {cannot use namespace qualifiers in hidden command token (rename)}} sl@0: sl@0: test interp-21.1 {interp hidden} { sl@0: interp hidden {} sl@0: } "" sl@0: test interp-21.2 {interp hidden} { sl@0: interp hidden sl@0: } "" sl@0: test interp-21.3 {interp hidden vs interp hide, interp expose} { sl@0: set l "" sl@0: lappend l [interp hidden] sl@0: interp hide {} pwd sl@0: lappend l [interp hidden] sl@0: interp expose {} pwd sl@0: lappend l [interp hidden] sl@0: set l sl@0: } {{} pwd {}} sl@0: test interp-21.4 {interp hidden} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: set l [interp hidden a] sl@0: interp delete a sl@0: set l sl@0: } "" sl@0: test interp-21.5 {interp hidden} { sl@0: catch {interp delete a} sl@0: interp create -safe a sl@0: set l [lsort [interp hidden a]] sl@0: interp delete a sl@0: set l sl@0: } $hidden_cmds sl@0: test interp-21.6 {interp hidden vs interp hide, interp expose} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: set l "" sl@0: lappend l [interp hidden a] sl@0: interp hide a pwd sl@0: lappend l [interp hidden a] sl@0: interp expose a pwd sl@0: lappend l [interp hidden a] sl@0: interp delete a sl@0: set l sl@0: } {{} pwd {}} sl@0: test interp-21.7 {interp hidden} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: set l [a hidden] sl@0: interp delete a sl@0: set l sl@0: } "" sl@0: test interp-21.8 {interp hidden} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l [lsort [a hidden]] sl@0: interp delete a sl@0: set l sl@0: } $hidden_cmds sl@0: test interp-21.9 {interp hidden vs interp hide, interp expose} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: set l "" sl@0: lappend l [a hidden] sl@0: a hide pwd sl@0: lappend l [a hidden] sl@0: a expose pwd sl@0: lappend l [a hidden] sl@0: interp delete a sl@0: set l sl@0: } {{} pwd {}} sl@0: sl@0: test interp-22.1 {testing interp marktrusted} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: set l "" sl@0: lappend l [a issafe] sl@0: lappend l [a marktrusted] sl@0: lappend l [a issafe] sl@0: interp delete a sl@0: set l sl@0: } {0 {} 0} sl@0: test interp-22.2 {testing interp marktrusted} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: set l "" sl@0: lappend l [interp issafe a] sl@0: lappend l [interp marktrusted a] sl@0: lappend l [interp issafe a] sl@0: interp delete a sl@0: set l sl@0: } {0 {} 0} sl@0: test interp-22.3 {testing interp marktrusted} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [a issafe] sl@0: lappend l [a marktrusted] sl@0: lappend l [a issafe] sl@0: interp delete a sl@0: set l sl@0: } {1 {} 0} sl@0: test interp-22.4 {testing interp marktrusted} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [interp issafe a] sl@0: lappend l [interp marktrusted a] sl@0: lappend l [interp issafe a] sl@0: interp delete a sl@0: set l sl@0: } {1 {} 0} sl@0: test interp-22.5 {testing interp marktrusted} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: interp create {a b} sl@0: catch {a eval {interp marktrusted b}} msg sl@0: interp delete a sl@0: set msg sl@0: } {permission denied: safe interpreter cannot mark trusted} sl@0: test interp-22.6 {testing interp marktrusted} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: interp create {a b} sl@0: catch {a eval {b marktrusted}} msg sl@0: interp delete a sl@0: set msg sl@0: } {permission denied: safe interpreter cannot mark trusted} sl@0: test interp-22.7 {testing interp marktrusted} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [interp issafe a] sl@0: interp marktrusted a sl@0: interp create {a b} sl@0: lappend l [interp issafe a] sl@0: lappend l [interp issafe {a b}] sl@0: interp delete a sl@0: set l sl@0: } {1 0 0} sl@0: test interp-22.8 {testing interp marktrusted} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [interp issafe a] sl@0: interp create {a b} sl@0: lappend l [interp issafe {a b}] sl@0: interp marktrusted a sl@0: interp create {a c} sl@0: lappend l [interp issafe a] sl@0: lappend l [interp issafe {a c}] sl@0: interp delete a sl@0: set l sl@0: } {1 1 0 0} sl@0: test interp-22.9 {testing interp marktrusted} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [interp issafe a] sl@0: interp create {a b} sl@0: lappend l [interp issafe {a b}] sl@0: interp marktrusted {a b} sl@0: lappend l [interp issafe a] sl@0: lappend l [interp issafe {a b}] sl@0: interp create {a b c} sl@0: lappend l [interp issafe {a b c}] sl@0: interp delete a sl@0: set l sl@0: } {1 1 1 0 0} sl@0: sl@0: test interp-23.1 {testing hiding vs aliases} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: set l "" sl@0: lappend l [interp hidden a] sl@0: a alias bar bar sl@0: lappend l [interp aliases a] sl@0: lappend l [interp hidden a] sl@0: a hide bar sl@0: lappend l [interp aliases a] sl@0: lappend l [interp hidden a] sl@0: a alias bar {} sl@0: lappend l [interp aliases a] sl@0: lappend l [interp hidden a] sl@0: interp delete a sl@0: set l sl@0: } {{} bar {} bar bar {} {}} sl@0: test interp-23.2 {testing hiding vs aliases} {unixOrPc} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [lsort [interp hidden a]] sl@0: a alias bar bar sl@0: lappend l [interp aliases a] sl@0: lappend l [lsort [interp hidden a]] sl@0: a hide bar sl@0: lappend l [interp aliases a] sl@0: lappend l [lsort [interp hidden a]] sl@0: a alias bar {} sl@0: lappend l [interp aliases a] sl@0: lappend l [lsort [interp hidden a]] sl@0: interp delete a sl@0: set l sl@0: } {{cd encoding exec exit fconfigure file glob load open pwd socket source} bar {cd encoding exec exit fconfigure file glob load open pwd socket source} bar {bar cd encoding exec exit fconfigure file glob load open pwd socket source} {} {cd encoding exec exit fconfigure file glob load open pwd socket source}} sl@0: sl@0: test interp-23.3 {testing hiding vs aliases} {macOnly} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: set l "" sl@0: lappend l [lsort [interp hidden a]] sl@0: a alias bar bar sl@0: lappend l [interp aliases a] sl@0: lappend l [lsort [interp hidden a]] sl@0: a hide bar sl@0: lappend l [interp aliases a] sl@0: lappend l [lsort [interp hidden a]] sl@0: a alias bar {} sl@0: lappend l [interp aliases a] sl@0: lappend l [lsort [interp hidden a]] sl@0: interp delete a sl@0: set l sl@0: } {{beep cd echo encoding exit fconfigure file glob load ls open pwd socket source} bar {beep cd echo encoding exit fconfigure file glob load ls open pwd socket source} bar {bar beep cd echo encoding exit fconfigure file glob load ls open pwd socket source} {} {beep cd echo encoding exit fconfigure file glob load ls open pwd socket source}} sl@0: sl@0: test interp-24.1 {result resetting on error} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: proc foo args {error $args} sl@0: interp alias a foo {} foo sl@0: set l [interp eval a { sl@0: set l {} sl@0: lappend l [catch {foo 1 2 3} msg] sl@0: lappend l $msg sl@0: lappend l [catch {foo 3 4 5} msg] sl@0: lappend l $msg sl@0: set l sl@0: }] sl@0: interp delete a sl@0: set l sl@0: } {1 {1 2 3} 1 {3 4 5}} sl@0: test interp-24.2 {result resetting on error} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: proc foo args {error $args} sl@0: interp alias a foo {} foo sl@0: set l [interp eval a { sl@0: set l {} sl@0: lappend l [catch {foo 1 2 3} msg] sl@0: lappend l $msg sl@0: lappend l [catch {foo 3 4 5} msg] sl@0: lappend l $msg sl@0: set l sl@0: }] sl@0: interp delete a sl@0: set l sl@0: } {1 {1 2 3} 1 {3 4 5}} sl@0: test interp-24.3 {result resetting on error} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp create {a b} sl@0: interp eval a { sl@0: proc foo args {error $args} sl@0: } sl@0: interp alias {a b} foo a foo sl@0: set l [interp eval {a b} { sl@0: set l {} sl@0: lappend l [catch {foo 1 2 3} msg] sl@0: lappend l $msg sl@0: lappend l [catch {foo 3 4 5} msg] sl@0: lappend l $msg sl@0: set l sl@0: }] sl@0: interp delete a sl@0: set l sl@0: } {1 {1 2 3} 1 {3 4 5}} sl@0: test interp-24.4 {result resetting on error} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: interp create {a b} sl@0: interp eval a { sl@0: proc foo args {error $args} sl@0: } sl@0: interp alias {a b} foo a foo sl@0: set l [interp eval {a b} { sl@0: set l {} sl@0: lappend l [catch {foo 1 2 3} msg] sl@0: lappend l $msg sl@0: lappend l [catch {foo 3 4 5} msg] sl@0: lappend l $msg sl@0: set l sl@0: }] sl@0: interp delete a sl@0: set l sl@0: } {1 {1 2 3} 1 {3 4 5}} sl@0: test interp-24.5 {result resetting on error} { sl@0: catch {interp delete a} sl@0: catch {interp delete b} sl@0: interp create a sl@0: interp create b sl@0: interp eval a { sl@0: proc foo args {error $args} sl@0: } sl@0: interp alias b foo a foo sl@0: set l [interp eval b { sl@0: set l {} sl@0: lappend l [catch {foo 1 2 3} msg] sl@0: lappend l $msg sl@0: lappend l [catch {foo 3 4 5} msg] sl@0: lappend l $msg sl@0: set l sl@0: }] sl@0: interp delete a sl@0: set l sl@0: } {1 {1 2 3} 1 {3 4 5}} sl@0: test interp-24.6 {result resetting on error} { sl@0: catch {interp delete a} sl@0: catch {interp delete b} sl@0: interp create a -safe sl@0: interp create b -safe sl@0: interp eval a { sl@0: proc foo args {error $args} sl@0: } sl@0: interp alias b foo a foo sl@0: set l [interp eval b { sl@0: set l {} sl@0: lappend l [catch {foo 1 2 3} msg] sl@0: lappend l $msg sl@0: lappend l [catch {foo 3 4 5} msg] sl@0: lappend l $msg sl@0: set l sl@0: }] sl@0: interp delete a sl@0: set l sl@0: } {1 {1 2 3} 1 {3 4 5}} sl@0: test interp-24.7 {result resetting on error} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp eval a { sl@0: proc foo args {error $args} sl@0: } sl@0: set l {} sl@0: lappend l [catch {interp eval a foo 1 2 3} msg] sl@0: lappend l $msg sl@0: lappend l [catch {interp eval a foo 3 4 5} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {1 2 3} 1 {3 4 5}} sl@0: test interp-24.8 {result resetting on error} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: interp eval a { sl@0: proc foo args {error $args} sl@0: } sl@0: set l {} sl@0: lappend l [catch {interp eval a foo 1 2 3} msg] sl@0: lappend l $msg sl@0: lappend l [catch {interp eval a foo 3 4 5} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {1 2 3} 1 {3 4 5}} sl@0: test interp-24.9 {result resetting on error} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp create {a b} sl@0: interp eval {a b} { sl@0: proc foo args {error $args} sl@0: } sl@0: interp eval a { sl@0: proc foo args { sl@0: eval interp eval b foo $args sl@0: } sl@0: } sl@0: set l {} sl@0: lappend l [catch {interp eval a foo 1 2 3} msg] sl@0: lappend l $msg sl@0: lappend l [catch {interp eval a foo 3 4 5} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {1 2 3} 1 {3 4 5}} sl@0: test interp-24.10 {result resetting on error} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: interp create {a b} sl@0: interp eval {a b} { sl@0: proc foo args {error $args} sl@0: } sl@0: interp eval a { sl@0: proc foo args { sl@0: eval interp eval b foo $args sl@0: } sl@0: } sl@0: set l {} sl@0: lappend l [catch {interp eval a foo 1 2 3} msg] sl@0: lappend l $msg sl@0: lappend l [catch {interp eval a foo 3 4 5} msg] sl@0: lappend l $msg sl@0: interp delete a sl@0: set l sl@0: } {1 {1 2 3} 1 {3 4 5}} sl@0: test interp-24.11 {result resetting on error} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp create {a b} sl@0: interp eval {a b} { sl@0: proc foo args {error $args} sl@0: } sl@0: interp eval a { sl@0: proc foo args { sl@0: set l {} sl@0: lappend l [catch {eval interp eval b foo $args} msg] sl@0: lappend l $msg sl@0: lappend l [catch {eval interp eval b foo $args} msg] sl@0: lappend l $msg sl@0: set l sl@0: } sl@0: } sl@0: set l [interp eval a foo 1 2 3] sl@0: interp delete a sl@0: set l sl@0: } {1 {1 2 3} 1 {1 2 3}} sl@0: test interp-24.12 {result resetting on error} { sl@0: catch {interp delete a} sl@0: interp create a -safe sl@0: interp create {a b} sl@0: interp eval {a b} { sl@0: proc foo args {error $args} sl@0: } sl@0: interp eval a { sl@0: proc foo args { sl@0: set l {} sl@0: lappend l [catch {eval interp eval b foo $args} msg] sl@0: lappend l $msg sl@0: lappend l [catch {eval interp eval b foo $args} msg] sl@0: lappend l $msg sl@0: set l sl@0: } sl@0: } sl@0: set l [interp eval a foo 1 2 3] sl@0: interp delete a sl@0: set l sl@0: } {1 {1 2 3} 1 {1 2 3}} sl@0: sl@0: unset hidden_cmds sl@0: sl@0: test interp-25.1 {testing aliasing of string commands} { sl@0: catch {interp delete a} sl@0: interp create a sl@0: a alias exec foo ;# Relies on exec being a string command! sl@0: interp delete a sl@0: } "" sl@0: sl@0: sl@0: # sl@0: # Interps result transmission sl@0: # sl@0: sl@0: test interp-26.1 {result code transmission : interp eval direct} { sl@0: # Test that all the possibles error codes from Tcl get passed up sl@0: # from the slave interp's context to the master, even though the sl@0: # slave nominally thinks the command is running at the root level. sl@0: sl@0: catch {interp delete a} sl@0: interp create a sl@0: set res {} sl@0: # use a for so if a return -code break 'escapes' we would notice sl@0: for {set code -1} {$code<=5} {incr code} { sl@0: lappend res [catch {interp eval a return -code $code} msg] sl@0: } sl@0: interp delete a sl@0: set res sl@0: } {-1 0 1 2 3 4 5} sl@0: sl@0: sl@0: test interp-26.2 {result code transmission : interp eval indirect} { sl@0: # retcode == 2 == return is special sl@0: catch {interp delete a} sl@0: interp create a sl@0: interp eval a {proc retcode {code} {return -code $code ret$code}} sl@0: set res {} sl@0: # use a for so if a return -code break 'escapes' we would notice sl@0: for {set code -1} {$code<=5} {incr code} { sl@0: lappend res [catch {interp eval a retcode $code} msg] $msg sl@0: } sl@0: interp delete a sl@0: set res sl@0: } {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} sl@0: sl@0: test interp-26.3 {result code transmission : aliases} { sl@0: # Test that all the possibles error codes from Tcl get passed up sl@0: # from the slave interp's context to the master, even though the sl@0: # slave nominally thinks the command is running at the root level. sl@0: sl@0: catch {interp delete a} sl@0: interp create a sl@0: set res {} sl@0: proc MyTestAlias {code} { sl@0: return -code $code ret$code sl@0: } sl@0: interp alias a Test {} MyTestAlias sl@0: for {set code -1} {$code<=5} {incr code} { sl@0: lappend res [interp eval a [list catch [list Test $code] msg]] sl@0: } sl@0: interp delete a sl@0: set res sl@0: } {-1 0 1 2 3 4 5} sl@0: sl@0: test interp-26.4 {result code transmission: invoke hidden direct--bug 1637} \ sl@0: {knownBug} { sl@0: # The known bug is that code 2 is returned, not the -code argument sl@0: catch {interp delete a} sl@0: interp create a sl@0: set res {} sl@0: interp hide a return sl@0: for {set code -1} {$code<=5} {incr code} { sl@0: lappend res [catch {interp invokehidden a return -code $code ret$code}] sl@0: } sl@0: interp delete a sl@0: set res sl@0: } {-1 0 1 2 3 4 5} sl@0: sl@0: test interp-26.5 {result code transmission: invoke hidden indirect--bug 1637} \ sl@0: {knownBug} { sl@0: # The known bug is that the break and continue should raise errors sl@0: # that they are used outside a loop. sl@0: catch {interp delete a} sl@0: interp create a sl@0: set res {} sl@0: interp eval a {proc retcode {code} {return -code $code ret$code}} sl@0: interp hide a retcode sl@0: for {set code -1} {$code<=5} {incr code} { sl@0: lappend res [catch {interp invokehidden a retcode $code} msg] $msg sl@0: } sl@0: interp delete a sl@0: set res sl@0: } {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} sl@0: sl@0: test interp-26.6 {result code transmission: all combined--bug 1637} \ sl@0: {knownBug} { sl@0: # Test that all the possibles error codes from Tcl get passed sl@0: # In both directions. This doesn't work. sl@0: set interp [interp create]; sl@0: proc MyTestAlias {interp args} { sl@0: global aliasTrace; sl@0: lappend aliasTrace $args; sl@0: eval interp invokehidden [list $interp] $args sl@0: } sl@0: foreach c {return} { sl@0: interp hide $interp $c; sl@0: interp alias $interp $c {} MyTestAlias $interp $c; sl@0: } sl@0: interp eval $interp {proc ret {code} {return -code $code ret$code}} sl@0: set res {} sl@0: set aliasTrace {} sl@0: for {set code -1} {$code<=5} {incr code} { sl@0: lappend res [catch {interp eval $interp ret $code} msg] $msg sl@0: } sl@0: interp delete $interp; sl@0: set res sl@0: } {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} sl@0: sl@0: # Some tests might need to be added to check for difference between sl@0: # toplevel and non toplevel evals. sl@0: sl@0: # End of return code transmission section sl@0: sl@0: test interp-26.7 {errorInfo transmission: regular interps} { sl@0: set interp [interp create]; sl@0: proc MyError {secret} { sl@0: return -code error "msg" sl@0: } sl@0: proc MyTestAlias {interp args} { sl@0: MyError "some secret" sl@0: } sl@0: interp alias $interp test {} MyTestAlias $interp; sl@0: set res [interp eval $interp {catch test;set errorInfo}] sl@0: interp delete $interp; sl@0: set res sl@0: } {msg sl@0: while executing sl@0: "MyError "some secret"" sl@0: (procedure "MyTestAlias" line 2) sl@0: invoked from within sl@0: "test"} sl@0: sl@0: test interp-26.8 {errorInfo transmission: safe interps--bug 1637} {knownBug} { sl@0: # this test fails because the errorInfo is fully transmitted sl@0: # whether the interp is safe or not. The errorInfo should never sl@0: # report data from the master interpreter because it could sl@0: # contain sensitive information. sl@0: set interp [interp create -safe]; sl@0: proc MyError {secret} { sl@0: return -code error "msg" sl@0: } sl@0: proc MyTestAlias {interp args} { sl@0: MyError "some secret" sl@0: } sl@0: interp alias $interp test {} MyTestAlias $interp; sl@0: set res [interp eval $interp {catch test;set errorInfo}] sl@0: interp delete $interp; sl@0: set res sl@0: } {msg sl@0: while executing sl@0: "test"} sl@0: sl@0: # Interps & Namespaces sl@0: test interp-27.1 {interp aliases & namespaces} { sl@0: set i [interp create]; sl@0: set aliasTrace {}; sl@0: proc tstAlias {args} { sl@0: global aliasTrace; sl@0: lappend aliasTrace [list [namespace current] $args]; sl@0: } sl@0: $i alias foo::bar tstAlias foo::bar; sl@0: $i eval foo::bar test sl@0: interp delete $i sl@0: set aliasTrace; sl@0: } {{:: {foo::bar test}}} sl@0: sl@0: test interp-27.2 {interp aliases & namespaces} { sl@0: set i [interp create]; sl@0: set aliasTrace {}; sl@0: proc tstAlias {args} { sl@0: global aliasTrace; sl@0: lappend aliasTrace [list [namespace current] $args]; sl@0: } sl@0: $i alias foo::bar tstAlias foo::bar; sl@0: $i eval namespace eval foo {bar test} sl@0: interp delete $i sl@0: set aliasTrace; sl@0: } {{:: {foo::bar test}}} sl@0: sl@0: test interp-27.3 {interp aliases & namespaces} { sl@0: set i [interp create]; sl@0: set aliasTrace {}; sl@0: proc tstAlias {args} { sl@0: global aliasTrace; sl@0: lappend aliasTrace [list [namespace current] $args]; sl@0: } sl@0: interp eval $i {namespace eval foo {proc bar {} {error "bar called"}}} sl@0: interp alias $i foo::bar {} tstAlias foo::bar; sl@0: interp eval $i {namespace eval foo {bar test}} sl@0: interp delete $i sl@0: set aliasTrace; sl@0: } {{:: {foo::bar test}}} sl@0: sl@0: test interp-27.4 {interp aliases & namespaces} { sl@0: set i [interp create]; sl@0: namespace eval foo2 { sl@0: variable aliasTrace {}; sl@0: proc bar {args} { sl@0: variable aliasTrace; sl@0: lappend aliasTrace [list [namespace current] $args]; sl@0: } sl@0: } sl@0: $i alias foo::bar foo2::bar foo::bar; sl@0: $i eval namespace eval foo {bar test} sl@0: set r $foo2::aliasTrace; sl@0: namespace delete foo2; sl@0: set r sl@0: } {{::foo2 {foo::bar test}}} sl@0: sl@0: # the following tests are commented out while we don't support sl@0: # hiding in namespaces sl@0: sl@0: # test interp-27.5 {interp hidden & namespaces} { sl@0: # set i [interp create]; sl@0: # interp eval $i { sl@0: # namespace eval foo { sl@0: # proc bar {args} { sl@0: # return "bar called ([namespace current]) ($args)" sl@0: # } sl@0: # } sl@0: # } sl@0: # set res [list [interp eval $i {namespace eval foo {bar test1}}]] sl@0: # interp hide $i foo::bar; sl@0: # lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg] sl@0: # interp delete $i; sl@0: # set res; sl@0: #} {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}} sl@0: sl@0: # test interp-27.6 {interp hidden & aliases & namespaces} { sl@0: # set i [interp create]; sl@0: # set v root-master; sl@0: # namespace eval foo { sl@0: # variable v foo-master; sl@0: # proc bar {interp args} { sl@0: # variable v; sl@0: # list "master bar called ($v) ([namespace current]) ($args)"\ sl@0: # [interp invokehidden $interp foo::bar $args]; sl@0: # } sl@0: # } sl@0: # interp eval $i { sl@0: # namespace eval foo { sl@0: # namespace export * sl@0: # variable v foo-slave; sl@0: # proc bar {args} { sl@0: # variable v; sl@0: # return "slave bar called ($v) ([namespace current]) ($args)" sl@0: # } sl@0: # } sl@0: # } sl@0: # set res [list [interp eval $i {namespace eval foo {bar test1}}]] sl@0: # $i hide foo::bar; sl@0: # $i alias foo::bar foo::bar $i; sl@0: # set res [concat $res [interp eval $i { sl@0: # set v root-slave; sl@0: # namespace eval test { sl@0: # variable v foo-test; sl@0: # namespace import ::foo::*; sl@0: # bar test2 sl@0: # } sl@0: # }]] sl@0: # namespace delete foo; sl@0: # interp delete $i; sl@0: # set res sl@0: # } {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}} sl@0: sl@0: sl@0: # test interp-27.7 {interp hidden & aliases & imports & namespaces} { sl@0: # set i [interp create]; sl@0: # set v root-master; sl@0: # namespace eval mfoo { sl@0: # variable v foo-master; sl@0: # proc bar {interp args} { sl@0: # variable v; sl@0: # list "master bar called ($v) ([namespace current]) ($args)"\ sl@0: # [interp invokehidden $interp test::bar $args]; sl@0: # } sl@0: # } sl@0: # interp eval $i { sl@0: # namespace eval foo { sl@0: # namespace export * sl@0: # variable v foo-slave; sl@0: # proc bar {args} { sl@0: # variable v; sl@0: # return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" sl@0: # } sl@0: # } sl@0: # set v root-slave; sl@0: # namespace eval test { sl@0: # variable v foo-test; sl@0: # namespace import ::foo::*; sl@0: # } sl@0: # } sl@0: # set res [list [interp eval $i {namespace eval test {bar test1}}]] sl@0: # $i hide test::bar; sl@0: # $i alias test::bar mfoo::bar $i; sl@0: # set res [concat $res [interp eval $i {test::bar test2}]]; sl@0: # namespace delete mfoo; sl@0: # interp delete $i; sl@0: # set res sl@0: # } {{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)}} sl@0: sl@0: #test interp-27.8 {hiding, namespaces and integrity} { sl@0: # namespace eval foo { sl@0: # variable v 3; sl@0: # proc bar {} {variable v; set v} sl@0: # # next command would currently generate an unknown command "bar" error. sl@0: # interp hide {} bar; sl@0: # } sl@0: # namespace delete foo; sl@0: # list [catch {interp invokehidden {} foo} msg] $msg; sl@0: #} {1 {invalid hidden command name "foo"}} sl@0: sl@0: sl@0: test interp-28.1 {getting fooled by slave's namespace ?} { sl@0: set i [interp create -safe]; sl@0: proc master {interp args} {interp hide $interp list} sl@0: $i alias master master $i; sl@0: set r [interp eval $i { sl@0: namespace eval foo { sl@0: proc list {args} { sl@0: return "dummy foo::list"; sl@0: } sl@0: master; sl@0: } sl@0: info commands list sl@0: }] sl@0: interp delete $i; sl@0: set r sl@0: } {} sl@0: sl@0: # Part 29: recursion limit sl@0: # 29.1.* Argument checking sl@0: # 29.2.* Reading and setting the recursion limit sl@0: # 29.3.* Does the recursion limit work? sl@0: # 29.4.* Recursion limit inheritance by sub-interpreters sl@0: # 29.5.* Confirming the recursionlimit command does not affect the parent sl@0: # 29.6.* Safe interpreter restriction sl@0: sl@0: test interp-29.1.1 {interp recursionlimit argument checking} { sl@0: list [catch {interp recursionlimit} msg] $msg sl@0: } {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}} sl@0: sl@0: test interp-29.1.2 {interp recursionlimit argument checking} { sl@0: list [catch {interp recursionlimit foo bar} msg] $msg sl@0: } {1 {could not find interpreter "foo"}} sl@0: sl@0: test interp-29.1.3 {interp recursionlimit argument checking} { sl@0: list [catch {interp recursionlimit foo bar baz} msg] $msg sl@0: } {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}} sl@0: sl@0: test interp-29.1.4 {interp recursionlimit argument checking} { sl@0: interp create moo sl@0: set result [catch {interp recursionlimit moo bar} msg] sl@0: interp delete moo sl@0: list $result $msg sl@0: } {1 {expected integer but got "bar"}} sl@0: sl@0: test interp-29.1.5 {interp recursionlimit argument checking} { sl@0: interp create moo sl@0: set result [catch {interp recursionlimit moo 0} msg] sl@0: interp delete moo sl@0: list $result $msg sl@0: } {1 {recursion limit must be > 0}} sl@0: sl@0: test interp-29.1.6 {interp recursionlimit argument checking} { sl@0: interp create moo sl@0: set result [catch {interp recursionlimit moo -1} msg] sl@0: interp delete moo sl@0: list $result $msg sl@0: } {1 {recursion limit must be > 0}} sl@0: sl@0: test interp-29.1.7 {interp recursionlimit argument checking} { sl@0: interp create moo sl@0: set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg] sl@0: interp delete moo sl@0: list $result [string range $msg 0 35] sl@0: } {1 {integer value too large to represent}} sl@0: sl@0: test interp-29.1.8 {slave recursionlimit argument checking} { sl@0: interp create moo sl@0: set result [catch {moo recursionlimit foo bar} msg] sl@0: interp delete moo sl@0: list $result $msg sl@0: } {1 {wrong # args: should be "moo recursionlimit ?newlimit?"}} sl@0: sl@0: test interp-29.1.9 {slave recursionlimit argument checking} { sl@0: interp create moo sl@0: set result [catch {moo recursionlimit foo} msg] sl@0: interp delete moo sl@0: list $result $msg sl@0: } {1 {expected integer but got "foo"}} sl@0: sl@0: test interp-29.1.10 {slave recursionlimit argument checking} { sl@0: interp create moo sl@0: set result [catch {moo recursionlimit 0} msg] sl@0: interp delete moo sl@0: list $result $msg sl@0: } {1 {recursion limit must be > 0}} sl@0: sl@0: test interp-29.1.11 {slave recursionlimit argument checking} { sl@0: interp create moo sl@0: set result [catch {moo recursionlimit -1} msg] sl@0: interp delete moo sl@0: list $result $msg sl@0: } {1 {recursion limit must be > 0}} sl@0: sl@0: test interp-29.1.12 {slave recursionlimit argument checking} { sl@0: interp create moo sl@0: set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg] sl@0: interp delete moo sl@0: list $result [string range $msg 0 35] sl@0: } {1 {integer value too large to represent}} sl@0: sl@0: test interp-29.2.1 {query recursion limit} { sl@0: interp recursionlimit {} sl@0: } 1000 sl@0: sl@0: test interp-29.2.2 {query recursion limit} { sl@0: set i [interp create] sl@0: set n [interp recursionlimit $i] sl@0: interp delete $i sl@0: set n sl@0: } 1000 sl@0: sl@0: test interp-29.2.3 {query recursion limit} { sl@0: set i [interp create] sl@0: set n [$i recursionlimit] sl@0: interp delete $i sl@0: set n sl@0: } 1000 sl@0: sl@0: test interp-29.2.4 {query recursion limit} { sl@0: set i [interp create] sl@0: set r [$i eval { sl@0: set n1 [interp recursionlimit {} 42] sl@0: set n2 [interp recursionlimit {}] sl@0: list $n1 $n2 sl@0: }] sl@0: interp delete $i sl@0: set r sl@0: } {42 42} sl@0: sl@0: test interp-29.2.5 {query recursion limit} { sl@0: set i [interp create] sl@0: set n1 [interp recursionlimit $i 42] sl@0: set n2 [interp recursionlimit $i] sl@0: interp delete $i sl@0: list $n1 $n2 sl@0: } {42 42} sl@0: sl@0: test interp-29.2.6 {query recursion limit} { sl@0: set i [interp create] sl@0: set n1 [interp recursionlimit $i 42] sl@0: set n2 [$i recursionlimit] sl@0: interp delete $i sl@0: list $n1 $n2 sl@0: } {42 42} sl@0: sl@0: test interp-29.2.7 {query recursion limit} { sl@0: set i [interp create] sl@0: set n1 [$i recursionlimit 42] sl@0: set n2 [interp recursionlimit $i] sl@0: interp delete $i sl@0: list $n1 $n2 sl@0: } {42 42} sl@0: sl@0: test interp-29.2.8 {query recursion limit} { sl@0: set i [interp create] sl@0: set n1 [$i recursionlimit 42] sl@0: set n2 [$i recursionlimit] sl@0: interp delete $i sl@0: list $n1 $n2 sl@0: } {42 42} sl@0: sl@0: test interp-29.3.1 {recursion limit} { sl@0: set i [interp create] sl@0: set r [interp eval $i { sl@0: interp recursionlimit {} 50 sl@0: proc p {} {incr ::i; p} sl@0: set i 0 sl@0: list [catch p msg] $msg $i sl@0: }] sl@0: interp delete $i sl@0: set r sl@0: } {1 {too many nested evaluations (infinite loop?)} 48} sl@0: sl@0: test interp-29.3.2 {recursion limit} { sl@0: set i [interp create] sl@0: interp recursionlimit $i 50 sl@0: set r [interp eval $i { sl@0: proc p {} {incr ::i; p} sl@0: set i 0 sl@0: list [catch p msg] $msg $i sl@0: }] sl@0: interp delete $i sl@0: set r sl@0: } {1 {too many nested evaluations (infinite loop?)} 48} sl@0: sl@0: test interp-29.3.3 {recursion limit} { sl@0: set i [interp create] sl@0: $i recursionlimit 50 sl@0: set r [interp eval $i { sl@0: proc p {} {incr ::i; p} sl@0: set i 0 sl@0: list [catch p msg] $msg $i sl@0: }] sl@0: interp delete $i sl@0: set r sl@0: } {1 {too many nested evaluations (infinite loop?)} 48} sl@0: sl@0: test interp-29.3.4 {recursion limit error reporting} { sl@0: interp create slave sl@0: set r1 [slave eval { sl@0: catch { # nesting level 1 sl@0: eval { # 2 sl@0: eval { # 3 sl@0: eval { # 4 sl@0: eval { # 5 sl@0: interp recursionlimit {} 5 sl@0: set x ok sl@0: } sl@0: } sl@0: } sl@0: } sl@0: } msg sl@0: }] sl@0: set r2 [slave eval { set msg }] sl@0: interp delete slave sl@0: list $r1 $r2 sl@0: } {1 {falling back due to new recursion limit}} sl@0: sl@0: test interp-29.3.5 {recursion limit error reporting} { sl@0: interp create slave sl@0: set r1 [slave eval { sl@0: catch { # nesting level 1 sl@0: eval { # 2 sl@0: eval { # 3 sl@0: eval { # 4 sl@0: eval { # 5 sl@0: interp recursionlimit {} 4 sl@0: set x ok sl@0: } sl@0: } sl@0: } sl@0: } sl@0: } msg sl@0: }] sl@0: set r2 [slave eval { set msg }] sl@0: interp delete slave sl@0: list $r1 $r2 sl@0: } {1 {falling back due to new recursion limit}} sl@0: sl@0: test interp-29.3.6 {recursion limit error reporting} { sl@0: interp create slave sl@0: set r1 [slave eval { sl@0: catch { # nesting level 1 sl@0: eval { # 2 sl@0: eval { # 3 sl@0: eval { # 4 sl@0: eval { # 5 sl@0: interp recursionlimit {} 6 sl@0: set x ok sl@0: } sl@0: } sl@0: } sl@0: } sl@0: } msg sl@0: }] sl@0: set r2 [slave eval { set msg }] sl@0: interp delete slave sl@0: list $r1 $r2 sl@0: } {0 ok} sl@0: sl@0: test interp-29.3.7 {recursion limit error reporting} { sl@0: interp create slave sl@0: after 0 {interp recursionlimit slave 5} sl@0: set r1 [slave eval { sl@0: catch { # nesting level 1 sl@0: eval { # 2 sl@0: eval { # 3 sl@0: eval { # 4 sl@0: eval { # 5 sl@0: update sl@0: set x ok sl@0: } sl@0: } sl@0: } sl@0: } sl@0: } msg sl@0: }] sl@0: set r2 [slave eval { set msg }] sl@0: interp delete slave sl@0: list $r1 $r2 sl@0: } {1 {too many nested evaluations (infinite loop?)}} sl@0: sl@0: test interp-29.3.8 {recursion limit error reporting} { sl@0: interp create slave sl@0: after 0 {interp recursionlimit slave 4} sl@0: set r1 [slave eval { sl@0: catch { # nesting level 1 sl@0: eval { # 2 sl@0: eval { # 3 sl@0: eval { # 4 sl@0: eval { # 5 sl@0: update sl@0: set x ok sl@0: } sl@0: } sl@0: } sl@0: } sl@0: } msg sl@0: }] sl@0: set r2 [slave eval { set msg }] sl@0: interp delete slave sl@0: list $r1 $r2 sl@0: } {1 {too many nested evaluations (infinite loop?)}} sl@0: sl@0: test interp-29.3.9 {recursion limit error reporting} { sl@0: interp create slave sl@0: after 0 {interp recursionlimit slave 6} sl@0: set r1 [slave eval { sl@0: catch { # nesting level 1 sl@0: eval { # 2 sl@0: eval { # 3 sl@0: eval { # 4 sl@0: eval { # 5 sl@0: update sl@0: set x ok sl@0: } sl@0: } sl@0: } sl@0: } sl@0: } msg sl@0: }] sl@0: set r2 [slave eval { set msg }] sl@0: interp delete slave sl@0: list $r1 $r2 sl@0: } {0 ok} sl@0: sl@0: test interp-29.3.10 {recursion limit error reporting} { sl@0: interp create slave sl@0: after 0 {slave recursionlimit 4} sl@0: set r1 [slave eval { sl@0: catch { # nesting level 1 sl@0: eval { # 2 sl@0: eval { # 3 sl@0: eval { # 4 sl@0: eval { # 5 sl@0: update sl@0: set x ok sl@0: } sl@0: } sl@0: } sl@0: } sl@0: } msg sl@0: }] sl@0: set r2 [slave eval { set msg }] sl@0: interp delete slave sl@0: list $r1 $r2 sl@0: } {1 {too many nested evaluations (infinite loop?)}} sl@0: sl@0: test interp-29.3.11 {recursion limit error reporting} { sl@0: interp create slave sl@0: after 0 {slave recursionlimit 5} sl@0: set r1 [slave eval { sl@0: catch { # nesting level 1 sl@0: eval { # 2 sl@0: eval { # 3 sl@0: eval { # 4 sl@0: eval { # 5 sl@0: update sl@0: set x ok sl@0: } sl@0: } sl@0: } sl@0: } sl@0: } msg sl@0: }] sl@0: set r2 [slave eval { set msg }] sl@0: interp delete slave sl@0: list $r1 $r2 sl@0: } {1 {too many nested evaluations (infinite loop?)}} sl@0: sl@0: test interp-29.3.12 {recursion limit error reporting} { sl@0: interp create slave sl@0: after 0 {slave recursionlimit 6} sl@0: set r1 [slave eval { sl@0: catch { # nesting level 1 sl@0: eval { # 2 sl@0: eval { # 3 sl@0: eval { # 4 sl@0: eval { # 5 sl@0: update sl@0: set x ok sl@0: } sl@0: } sl@0: } sl@0: } sl@0: } msg sl@0: }] sl@0: set r2 [slave eval { set msg }] sl@0: interp delete slave sl@0: list $r1 $r2 sl@0: } {0 ok} sl@0: sl@0: test interp-29.4.1 {recursion limit inheritance} { sl@0: set i [interp create] sl@0: set ii [interp eval $i { sl@0: interp recursionlimit {} 50 sl@0: interp create sl@0: }] sl@0: set r [interp eval [list $i $ii] { sl@0: proc p {} {incr ::i; p} sl@0: set i 0 sl@0: catch p sl@0: set i sl@0: }] sl@0: interp delete $i sl@0: set r sl@0: } 49 sl@0: sl@0: test interp-29.4.2 {recursion limit inheritance} { sl@0: set i [interp create] sl@0: $i recursionlimit 50 sl@0: set ii [interp eval $i {interp create}] sl@0: set r [interp eval [list $i $ii] { sl@0: proc p {} {incr ::i; p} sl@0: set i 0 sl@0: catch p sl@0: set i sl@0: }] sl@0: interp delete $i sl@0: set r sl@0: } 49 sl@0: sl@0: test interp-29.5.1 {does slave recursion limit affect master?} { sl@0: set before [interp recursionlimit {}] sl@0: set i [interp create] sl@0: interp recursionlimit $i 20000 sl@0: set after [interp recursionlimit {}] sl@0: set slavelimit [interp recursionlimit $i] sl@0: interp delete $i sl@0: list [expr {$before == $after}] $slavelimit sl@0: } {1 20000} sl@0: sl@0: test interp-29.5.2 {does slave recursion limit affect master?} { sl@0: set before [interp recursionlimit {}] sl@0: set i [interp create] sl@0: interp recursionlimit $i 20000 sl@0: set after [interp recursionlimit {}] sl@0: set slavelimit [$i recursionlimit] sl@0: interp delete $i sl@0: list [expr {$before == $after}] $slavelimit sl@0: } {1 20000} sl@0: sl@0: test interp-29.5.3 {does slave recursion limit affect master?} { sl@0: set before [interp recursionlimit {}] sl@0: set i [interp create] sl@0: $i recursionlimit 20000 sl@0: set after [interp recursionlimit {}] sl@0: set slavelimit [interp recursionlimit $i] sl@0: interp delete $i sl@0: list [expr {$before == $after}] $slavelimit sl@0: } {1 20000} sl@0: sl@0: test interp-29.5.4 {does slave recursion limit affect master?} { sl@0: set before [interp recursionlimit {}] sl@0: set i [interp create] sl@0: $i recursionlimit 20000 sl@0: set after [interp recursionlimit {}] sl@0: set slavelimit [$i recursionlimit] sl@0: interp delete $i sl@0: list [expr {$before == $after}] $slavelimit sl@0: } {1 20000} sl@0: sl@0: test interp-29.6.1 {safe interpreter recursion limit} { sl@0: interp create slave -safe sl@0: set n [interp recursionlimit slave] sl@0: interp delete slave sl@0: set n sl@0: } 1000 sl@0: sl@0: test interp-29.6.2 {safe interpreter recursion limit} { sl@0: interp create slave -safe sl@0: set n [slave recursionlimit] sl@0: interp delete slave sl@0: set n sl@0: } 1000 sl@0: sl@0: test interp-29.6.3 {safe interpreter recursion limit} { sl@0: interp create slave -safe sl@0: set n1 [interp recursionlimit slave 42] sl@0: set n2 [interp recursionlimit slave] sl@0: interp delete slave sl@0: list $n1 $n2 sl@0: } {42 42} sl@0: sl@0: test interp-29.6.4 {safe interpreter recursion limit} { sl@0: interp create slave -safe sl@0: set n1 [slave recursionlimit 42] sl@0: set n2 [interp recursionlimit slave] sl@0: interp delete slave sl@0: list $n1 $n2 sl@0: } {42 42} sl@0: sl@0: test interp-29.6.5 {safe interpreter recursion limit} { sl@0: interp create slave -safe sl@0: set n1 [interp recursionlimit slave 42] sl@0: set n2 [slave recursionlimit] sl@0: interp delete slave sl@0: list $n1 $n2 sl@0: } {42 42} sl@0: sl@0: test interp-29.6.6 {safe interpreter recursion limit} { sl@0: interp create slave -safe sl@0: set n1 [slave recursionlimit 42] sl@0: set n2 [slave recursionlimit] sl@0: interp delete slave sl@0: list $n1 $n2 sl@0: } {42 42} sl@0: sl@0: test interp-29.6.7 {safe interpreter recursion limit} { sl@0: interp create slave -safe sl@0: set n1 [slave recursionlimit 42] sl@0: set n2 [slave recursionlimit] sl@0: interp delete slave sl@0: list $n1 $n2 sl@0: } {42 42} sl@0: sl@0: test interp-29.6.8 {safe interpreter recursion limit} { sl@0: interp create slave -safe sl@0: set n [catch {slave eval {interp recursionlimit {} 42}} msg] sl@0: interp delete slave sl@0: list $n $msg sl@0: } {1 {permission denied: safe interpreters cannot change recursion limit}} sl@0: sl@0: test interp-29.6.9 {safe interpreter recursion limit} { sl@0: interp create slave -safe sl@0: set result [ sl@0: slave eval { sl@0: interp create slave2 -safe sl@0: set n [catch { sl@0: interp recursionlimit slave2 42 sl@0: } msg] sl@0: list $n $msg sl@0: } sl@0: ] sl@0: interp delete slave sl@0: set result sl@0: } {1 {permission denied: safe interpreters cannot change recursion limit}} sl@0: sl@0: test interp-29.6.10 {safe interpreter recursion limit} { sl@0: interp create slave -safe sl@0: set result [ sl@0: slave eval { sl@0: interp create slave2 -safe sl@0: set n [catch { sl@0: slave2 recursionlimit 42 sl@0: } msg] sl@0: list $n $msg sl@0: } sl@0: ] sl@0: interp delete slave sl@0: set result sl@0: } {1 {permission denied: safe interpreters cannot change recursion limit}} sl@0: sl@0: sl@0: # # Deep recursion (into interps when the regular one fails): sl@0: # # still crashes... sl@0: # proc p {} { sl@0: # if {[catch p ret]} { sl@0: # catch { sl@0: # set i [interp create] sl@0: # interp eval $i [list proc p {} [info body p]] sl@0: # interp eval $i p sl@0: # } sl@0: # interp delete $i sl@0: # return ok sl@0: # } sl@0: # return $ret sl@0: # } sl@0: # p sl@0: sl@0: # more tests needed... sl@0: sl@0: # Interp & stack sl@0: #test interp-29.1 {interp and stack (info level)} { sl@0: #} {} sl@0: sl@0: # End of stack-recursion tests sl@0: sl@0: # This test dumps core in Tcl 8.0.3! sl@0: test interp-30.1 {deletion of aliases inside namespaces} { sl@0: set i [interp create] sl@0: $i alias ns::cmd list sl@0: $i alias ns::cmd {} sl@0: } {} sl@0: sl@0: test interp-31.1 {alias invocation scope} { sl@0: proc mySet {varName value} { sl@0: upvar 1 $varName localVar sl@0: set localVar $value sl@0: } sl@0: sl@0: interp alias {} myNewSet {} mySet sl@0: proc testMyNewSet {value} { sl@0: myNewSet a $value sl@0: return $a sl@0: } sl@0: catch {unset a} sl@0: set result [testMyNewSet "ok"] sl@0: rename testMyNewSet {} sl@0: rename mySet {} sl@0: rename myNewSet {} sl@0: set result sl@0: } ok sl@0: sl@0: test interp-32.1 { parent's working directory should sl@0: be inherited by a child interp } { sl@0: cd [temporaryDirectory] sl@0: set parent [pwd] sl@0: set i [interp create] sl@0: set child [$i eval pwd] sl@0: interp delete $i sl@0: file mkdir cwd_test sl@0: cd cwd_test sl@0: lappend parent [pwd] sl@0: set i [interp create] sl@0: lappend child [$i eval pwd] sl@0: cd .. sl@0: file delete cwd_test sl@0: interp delete $i sl@0: cd [workingDirectory] sl@0: expr {[string equal $parent $child] ? 1 : sl@0: "\{$parent\} != \{$child\}"} sl@0: } 1 sl@0: sl@0: test interp-33.1 {refCounting for target words of alias [Bug 730244]} { sl@0: # This test will panic if Bug 730244 is not fixed. sl@0: set i [interp create] sl@0: proc testHelper args {rename testHelper {}; return $args} sl@0: # Note: interp names are simple words by default sl@0: trace add execution testHelper enter "interp alias $i alias {} ;#" sl@0: interp alias $i alias {} testHelper this sl@0: $i eval alias sl@0: } this sl@0: sl@0: # cleanup sl@0: foreach i [interp slaves] { sl@0: interp delete $i sl@0: } sl@0: ::tcltest::cleanupTests sl@0: return