diff options
| author | William Joye <wjoye@cfa.harvard.edu> | 2017-10-17 19:50:58 (GMT) |
|---|---|---|
| committer | William Joye <wjoye@cfa.harvard.edu> | 2017-10-17 19:50:58 (GMT) |
| commit | 9b7a6c3507ea3383c60aaecb29f873c9b590ccca (patch) | |
| tree | 82ce31ebd8f46803d969034f5aa3db8d7974493c /tcl8.6/tests/interp.test | |
| parent | 87fca7325b97005eb44dcf3e198277640af66115 (diff) | |
| download | blt-9b7a6c3507ea3383c60aaecb29f873c9b590ccca.zip blt-9b7a6c3507ea3383c60aaecb29f873c9b590ccca.tar.gz blt-9b7a6c3507ea3383c60aaecb29f873c9b590ccca.tar.bz2 | |
rm tcl/tk 8.6.7
Diffstat (limited to 'tcl8.6/tests/interp.test')
| -rw-r--r-- | tcl8.6/tests/interp.test | 3679 |
1 files changed, 0 insertions, 3679 deletions
diff --git a/tcl8.6/tests/interp.test b/tcl8.6/tests/interp.test deleted file mode 100644 index 5299d82..0000000 --- a/tcl8.6/tests/interp.test +++ /dev/null @@ -1,3679 +0,0 @@ -# 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::* -} - -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -testConstraint testinterpdelete [llength [info commands testinterpdelete]] - -set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl: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} -setup { - catch {interp create a} -} -returnCodes error -body { - interp create a -} -result {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} -setup { - catch {interp create a} -} -body { - interp create {a x1} - interp create {a x2} - interp create {a x3} -safe -} -result {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} -setup { - catch {interp create a} -} -body { - interp slaves -} -result 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} -setup { - catch {interp create a} -} -body { - interp create {a a2} -safe - expr {"a2" in [interp slaves a]} -} -result 1 -test interp-3.10 {testing interp exists and interp slaves} -setup { - catch {interp create a} - catch {interp create {a a2}} -} -body { - interp exists {a a2} -} -result 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 -catch {a eval {proc foo {} {expr 3 + 5}}} -test interp-6.4 {testing eval} { - interp eval a foo -} 8 -test interp-6.5 {testing eval} { - interp create {a x2} - interp eval {a x2} {proc frob {} {expr 4 * 9}} - interp eval {a x2} frob -} 36 -catch {interp create {a x2}} -test interp-6.6 {testing eval} -returnCodes error -body { - interp eval {a x2} foo -} -result {invalid command name "foo"} - -# UTILITY PROCEDURE RUNNING IN 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 -catch {a alias foo in_master} -test interp-7.2 {testing basic alias creation} { - a alias bar in_master a1 a2 a3 -} bar -catch {a alias bar in_master a1 a2 a3} -# 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} -setup { - interp create abc -} -body { - interp eval abc {interp aliases} -} -cleanup { - interp delete abc -} -result "" -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"} - -test interp-14.11 {{interp alias} {target named the empty string} {bug 2bf56185}} -setup { - set interp [interp create [info cmdcount]] - interp eval $interp { - proc {} args {return $args} - } - -} -body { - interp alias {} p1 $interp {} - p1 one two three -} -cleanup { - interp delete $interp -} -result {one two three} - -# part 15: testing file sharing -test interp-15.1 {testing file sharing} { - 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-16.0 {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-20.50.1 {Bug 2486550} -setup { - interp create slave -} -body { - slave hide coroutine - catch {slave invokehidden coroutine} m o - dict get $o -errorinfo -} -cleanup { - unset -nocomplain m 0 - interp delete slave -} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" - while executing -"coroutine" - invoked from within -"slave invokehidden coroutine"} - -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} -# Bug 3398794 -test interp-35.23 {interp command limits can't touch current interp} -body { - interp limit {} commands -value 10 -} -returnCodes error -result {limits on current interpreter inaccessible} -test interp-35.24 {interp time limits can't touch current interp} -body { - interp limit {} time -seconds 2 -} -returnCodes error -result {limits on current interpreter inaccessible} - -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} -constraints {!singleTestInterp} -body { - interp debug {} -} -result {-frame 0} -test interp-38.5 {interp debug basic setup} -constraints {!singleTestInterp} -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: |