interp.test
上传用户:rrhhcc
上传日期:2015-12-11
资源大小:54129k
文件大小:79k
- # 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.
- #
- # RCS: @(#) $Id: interp.test,v 1.19.2.6 2004/10/28 00:01:07 dgp Exp $
- if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2.1
- namespace import -force ::tcltest::*
- }
- # The set of hidden commands is platform dependent:
- if {"$tcl_platform(platform)" == "macintosh"} {
- set hidden_cmds {beep cd echo encoding exit fconfigure file glob load ls open pwd socket source}
- } else {
- set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source}
- }
- foreach i [interp slaves] {
- interp delete $i
- }
- proc equiv {x} {return $x}
- # Part 0: Check out options for interp command
- test interp-1.1 {options for interp command} {
- list [catch {interp} msg] $msg
- } {1 {wrong # args: should be "interp cmd ?arg ...?"}}
- test interp-1.2 {options for interp command} {
- list [catch {interp frobox} msg] $msg
- } {1 {bad option "frobox": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, 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} {
- list [catch {interp delete foo bar} msg] $msg
- } {1 {could not find interpreter "foo"}}
- test interp-1.5 {options for interp command} {
- list [catch {interp exists foo bar} msg] $msg
- } {1 {wrong # args: should be "interp exists ?path?"}}
- #
- # test interp-0.6 was removed
- #
- test interp-1.6 {options for interp command} {
- list [catch {interp slaves foo bar zop} msg] $msg
- } {1 {wrong # args: should be "interp slaves ?path?"}}
- test interp-1.7 {options for interp command} {
- list [catch {interp hello} msg] $msg
- } {1 {bad option "hello": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}}
- test interp-1.8 {options for interp command} {
- list [catch {interp -froboz} msg] $msg
- } {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}}
- test interp-1.9 {options for interp command} {
- list [catch {interp -froboz -safe} msg] $msg
- } {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}}
- test interp-1.10 {options for interp command} {
- list [catch {interp target} msg] $msg
- } {1 {wrong # args: should be "interp target path alias"}}
- # Part 1: Basic interpreter creation tests:
- test interp-2.1 {basic interpreter creation} {
- interp create a
- } a
- test interp-2.2 {basic interpreter creation} {
- catch {interp create}
- } 0
- test interp-2.3 {basic interpreter creation} {
- catch {interp create -safe}
- } 0
- test interp-2.4 {basic interpreter creation} {
- list [catch {interp create a} msg] $msg
- } {1 {interpreter named "a" already exists, cannot create}}
- test interp-2.5 {basic interpreter creation} {
- interp create b -safe
- } b
- test interp-2.6 {basic interpreter creation} {
- interp create d -safe
- } d
- test interp-2.7 {basic interpreter creation} {
- list [catch {interp create -froboz} msg] $msg
- } {1 {bad option "-froboz": must be -safe or --}}
- test interp-2.8 {basic interpreter creation} {
- interp create -- -froboz
- } -froboz
- test interp-2.9 {basic interpreter creation} {
- interp create -safe -- -froboz1
- } -froboz1
- test interp-2.10 {basic interpreter creation} {
- interp create {a x1}
- interp create {a x2}
- interp create {a x3} -safe
- } {a x3}
- test interp-2.11 {anonymous interps vs existing procs} {
- set x [interp create]
- regexp "interp([0-9]+)" $x dummy thenum
- interp delete $x
- proc interp$thenum {} {}
- set x [interp create]
- regexp "interp([0-9]+)" $x dummy anothernum
- expr $anothernum > $thenum
- } 1
- test interp-2.12 {anonymous interps vs existing procs} {
- set x [interp create -safe]
- regexp "interp([0-9]+)" $x dummy thenum
- interp delete $x
- proc interp$thenum {} {}
- set x [interp create -safe]
- regexp "interp([0-9]+)" $x dummy anothernum
- expr $anothernum - $thenum
- } 1
- test interp-2.13 {correct default when no $path arg is given} -body {
- interp create --
- } -match regexp -result {interp[0-9]+}
-
- foreach i [interp slaves] {
- interp delete $i
- }
- # Part 2: Testing "interp slaves" and "interp exists"
- test interp-3.1 {testing interp exists and interp slaves} {
- interp slaves
- } ""
- test interp-3.2 {testing interp exists and interp slaves} {
- interp create a
- interp exists a
- } 1
- test interp-3.3 {testing interp exists and interp slaves} {
- interp exists nonexistent
- } 0
- test interp-3.4 {testing interp exists and interp slaves} {
- list [catch {interp slaves a b c} msg] $msg
- } {1 {wrong # args: should be "interp slaves ?path?"}}
- test interp-3.5 {testing interp exists and interp slaves} {
- list [catch {interp exists a b c} msg] $msg
- } {1 {wrong # args: should be "interp exists ?path?"}}
- test interp-3.6 {testing interp exists and interp slaves} {
- interp exists
- } 1
- test interp-3.7 {testing interp exists and interp slaves} {
- interp slaves
- } a
- test interp-3.8 {testing interp exists and interp slaves} {
- list [catch {interp slaves a b c} msg] $msg
- } {1 {wrong # args: should be "interp slaves ?path?"}}
- test interp-3.9 {testing interp exists and interp slaves} {
- interp create {a a2} -safe
- expr {[lsearch [interp slaves a] a2] >= 0}
- } 1
- test interp-3.10 {testing interp exists and interp slaves} {
- interp exists {a a2}
- } 1
- # Part 3: Testing "interp delete"
- test interp-3.11 {testing interp delete} {
- interp delete
- } ""
- test interp-4.1 {testing interp delete} {
- catch {interp create a}
- interp delete a
- } ""
- test interp-4.2 {testing interp delete} {
- list [catch {interp delete nonexistent} msg] $msg
- } {1 {could not find interpreter "nonexistent"}}
- test interp-4.3 {testing interp delete} {
- list [catch {interp delete x y z} msg] $msg
- } {1 {could not find interpreter "x"}}
- test interp-4.4 {testing interp delete} {
- interp delete
- } ""
- test interp-4.5 {testing interp delete} {
- interp create a
- interp create {a x1}
- interp delete {a x1}
- expr {[lsearch [interp slaves a] x1] >= 0}
- } 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} {
- interp create c1
- interp create c2
- list [catch {interp delete c1 c2 c3} msg] $msg
- } {1 {could not find interpreter "c3"}}
- test interp-4.8 {testing interp delete} {
- list [catch {interp delete {}} msg] $msg
- } {1 {cannot delete the current interpreter}}
- foreach i [interp 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} {
- list [catch {a eval foo} msg] $msg
- } {1 {invalid command name "foo"}}
- test interp-6.3 {testing eval} {
- a eval {proc foo {} {expr 3 + 5}}
- a eval foo
- } 8
- test interp-6.4 {testing eval} {
- interp eval a foo
- } 8
- test interp-6.5 {testing eval} {
- interp create {a x2}
- interp eval {a x2} {proc frob {} {expr 4 * 9}}
- interp eval {a x2} frob
- } 36
- test interp-6.6 {testing eval} {
- list [catch {interp eval {a x2} foo} msg] $msg
- } {1 {invalid command name "foo"}}
- # UTILITY PROCEDURE RUNNING IN MASTER INTERPRETER:
- proc in_master {args} {
- return [list seen in master: $args]
- }
- # Part 6: Testing basic alias creation
- test interp-7.1 {testing basic alias creation} {
- a alias foo in_master
- } foo
- test interp-7.2 {testing basic alias creation} {
- a alias bar in_master a1 a2 a3
- } bar
- # Test 6.3 has been deleted.
- test interp-7.3 {testing basic alias creation} {
- a alias foo
- } in_master
- test interp-7.4 {testing basic alias creation} {
- a alias bar
- } {in_master a1 a2 a3}
- test interp-7.5 {testing basic alias creation} {
- lsort [a aliases]
- } {bar foo}
- test interp-7.6 {testing basic aliases arg checking} {
- list [catch {a aliases too many args} msg] $msg
- } {1 {wrong # args: should be "a aliases"}}
- # Part 7: testing basic alias invocation
- test interp-8.1 {testing basic alias invocation} {
- catch {interp create a}
- a alias foo in_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} {
- catch {interp create a}
- list [catch {a alias} msg] $msg
- } {1 {wrong # args: should be "a alias aliasName ?targetName? ?args..?"}}
- # Part 8: Testing aliases for non-existent or hidden targets
- test interp-9.1 {testing aliases for non-existent targets} {
- catch {interp create a}
- a alias zop nonexistent-command-in-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 {}
- equiv $x
- } {33 33 33}
- # Part 10: Testing "interp target"
- test interp-11.1 {testing interp target} {
- list [catch {interp target} msg] $msg
- } {1 {wrong # args: should be "interp target path alias"}}
- test interp-11.2 {testing interp target} {
- list [catch {interp target nosuchinterpreter foo} msg] $msg
- } {1 {could not find interpreter "nosuchinterpreter"}}
- test interp-11.3 {testing interp target} {
- catch {interp delete a}
- interp create a
- a alias boo no_command
- interp target a boo
- } ""
- test interp-11.4 {testing interp target} {
- catch {interp delete x1}
- interp create x1
- x1 eval interp create x2
- x1 eval x2 eval interp create x3
- catch {interp delete y1}
- interp create y1
- y1 eval interp create y2
- y1 eval y2 eval interp create y3
- interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand
- interp target {x1 x2 x3} xcommand
- } {y1 y2 y3}
- test interp-11.5 {testing interp target} {
- catch {interp delete x1}
- interp create x1
- interp create {x1 x2}
- interp create {x1 x2 x3}
- catch {interp delete y1}
- interp create y1
- interp create {y1 y2}
- interp create {y1 y2 y3}
- interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand
- list [catch {x1 eval {interp target {x2 x3} xcommand}} msg] $msg
- } {1 {target interpreter for alias "xcommand" in path "x2 x3" is not my descendant}}
- test interp-11.6 {testing interp target} {
- foreach a [interp aliases] {
- rename $a {}
- }
- list [catch {interp target {} foo} msg] $msg
- } {1 {alias "foo" in path "" not found}}
- test interp-11.7 {testing interp target} {
- catch {interp delete a}
- interp create a
- list [catch {interp target a foo} msg] $msg
- } {1 {alias "foo" in path "a" not found}}
- # Part 11: testing "interp issafe"
- test interp-12.1 {testing interp issafe} {
- interp issafe
- } 0
- test interp-12.2 {testing interp issafe} {
- catch {interp delete a}
- interp create a
- interp issafe a
- } 0
- test interp-12.3 {testing interp issafe} {
- catch {interp delete a}
- interp create a
- interp create {a x3} -safe
- interp issafe {a x3}
- } 1
- test interp-12.4 {testing interp issafe} {
- catch {interp delete a}
- interp create a
- interp create {a x3} -safe
- interp create {a x3 foo}
- interp issafe {a x3 foo}
- } 1
- # Part 12: testing interpreter object command "issafe" sub-command
- test interp-13.1 {testing foo issafe} {
- catch {interp delete a}
- interp create a
- a issafe
- } 0
- test interp-13.2 {testing foo issafe} {
- catch {interp delete a}
- interp create a
- interp create {a x3} -safe
- a eval x3 issafe
- } 1
- test interp-13.3 {testing foo issafe} {
- catch {interp delete a}
- interp create a
- interp create {a x3} -safe
- interp create {a x3 foo}
- a eval x3 eval foo issafe
- } 1
- test interp-13.4 {testing issafe arg checking} {
- catch {interp create a}
- list [catch {a issafe too many args} msg] $msg
- } {1 {wrong # args: should be "a issafe"}}
- # part 14: testing interp aliases
- test interp-14.1 {testing interp aliases} {
- interp aliases
- } ""
- test interp-14.2 {testing interp aliases} {
- catch {interp delete a}
- interp create a
- a alias a1 puts
- a alias a2 puts
- a alias a3 puts
- lsort [interp aliases a]
- } {a1 a2 a3}
- test interp-14.3 {testing interp aliases} {
- catch {interp delete a}
- interp create a
- interp create {a x3}
- interp alias {a x3} froboz "" puts
- interp aliases {a x3}
- } froboz
- test interp-14.4 {testing interp alias - alias over master} {
- # SF Bug 641195
- catch {interp delete a}
- interp create a
- list [catch {interp alias "" a a eval} msg] $msg [info commands a]
- } {1 {cannot define or rename alias "a": interpreter deleted} {}}
- # part 15: testing file sharing
- test interp-15.1 {testing file sharing} {
- catch {interp delete z}
- interp create z
- z eval close stdout
- list [catch {z eval puts hello} msg] $msg
- } {1 {can not find channel named "stdout"}}
- test interp-15.2 {testing file sharing} -body {
- catch {interp delete z}
- interp create z
- set f [open [makeFile {} file-15.2] w]
- interp share "" $f z
- z eval puts $f hello
- z eval close $f
- close $f
- } -cleanup {
- removeFile file-15.2
- } -result ""
- test interp-15.3 {testing file sharing} {
- catch {interp delete xsafe}
- interp create xsafe -safe
- list [catch {xsafe eval puts hello} msg] $msg
- } {1 {can not find channel named "stdout"}}
- test interp-15.4 {testing file sharing} -body {
- catch {interp delete xsafe}
- interp create xsafe -safe
- set f [open [makeFile {} file-15.4] w]
- interp share "" $f xsafe
- xsafe eval puts $f hello
- xsafe eval close $f
- close $f
- } -cleanup {
- removeFile file-15.4
- } -result ""
- test interp-15.5 {testing file sharing} {
- catch {interp delete xsafe}
- interp create xsafe -safe
- interp share "" stdout xsafe
- list [catch {xsafe eval gets stdout} msg] $msg
- } {1 {channel "stdout" wasn't opened for reading}}
- test interp-15.6 {testing file sharing} -body {
- catch {interp delete xsafe}
- interp create xsafe -safe
- set f [open [makeFile {} file-15.6] w]
- interp share "" $f xsafe
- set x [list [catch [list xsafe eval gets $f] msg] $msg]
- xsafe eval close $f
- close $f
- string compare [string tolower $x]
- [list 1 [format "channel "%s" wasn't opened for reading" $f]]
- } -cleanup {
- removeFile file-15.6
- } -result 0
- test interp-15.7 {testing file transferring} -body {
- catch {interp delete xsafe}
- interp create xsafe -safe
- set f [open [makeFile {} file-15.7] w]
- interp transfer "" $f xsafe
- xsafe eval puts $f hello
- xsafe eval close $f
- } -cleanup {
- removeFile file-15.7
- } -result ""
- test interp-15.8 {testing file transferring} -body {
- catch {interp delete xsafe}
- interp create xsafe -safe
- set f [open [makeFile {} file-15.8] w]
- interp transfer "" $f xsafe
- xsafe eval close $f
- set x [list [catch {close $f} msg] $msg]
- string compare [string tolower $x]
- [list 1 [format "can not find channel named "%s"" $f]]
- } -cleanup {
- removeFile file-15.8
- } -result 0
- #
- # Torture tests for interpreter deletion order
- #
- proc kill {} {interp delete xxx}
- test interp-15.9 {testing deletion order} {
- catch {interp delete xxx}
- interp create xxx
- xxx alias kill kill
- list [catch {xxx eval kill} msg] $msg
- } {0 {}}
- test interp-16.1 {testing deletion order} {
- catch {interp delete xxx}
- interp create xxx
- interp create {xxx yyy}
- interp alias {xxx yyy} kill "" kill
- list [catch {interp eval {xxx yyy} kill} msg] $msg
- } {0 {}}
- test interp-16.2 {testing deletion order} {
- catch {interp delete xxx}
- interp create xxx
- interp create {xxx yyy}
- interp alias {xxx yyy} kill "" kill
- list [catch {xxx eval yyy eval kill} msg] $msg
- } {0 {}}
- test interp-16.3 {testing deletion order} {
- catch {interp delete xxx}
- interp create xxx
- interp create ddd
- xxx alias kill kill
- interp alias ddd kill xxx kill
- set x [ddd eval kill]
- interp delete ddd
- set x
- } ""
- test interp-16.4 {testing deletion order} {
- catch {interp delete xxx}
- interp create xxx
- interp create {xxx yyy}
- interp alias {xxx yyy} kill "" kill
- interp create ddd
- interp alias ddd kill {xxx yyy} kill
- set x [ddd eval kill]
- interp delete ddd
- set x
- } ""
- test interp-16.5 {testing deletion order, bgerror} {
- catch {interp delete xxx}
- interp create xxx
- xxx eval {proc bgerror {args} {exit}}
- xxx alias exit kill xxx
- proc kill {i} {interp delete $i}
- xxx eval after 100 expr a + b
- after 200
- update
- interp exists xxx
- } 0
- #
- # Alias loop prevention testing.
- #
- test interp-17.1 {alias loop prevention} {
- list [catch {interp alias {} a {} a} msg] $msg
- } {1 {cannot define or rename alias "a": would create a loop}}
- test interp-17.2 {alias loop prevention} {
- catch {interp delete x}
- interp create x
- x alias a loop
- list [catch {interp alias {} loop x a} msg] $msg
- } {1 {cannot define or rename alias "loop": would create a loop}}
- test interp-17.3 {alias loop prevention} {
- catch {interp delete x}
- interp create x
- interp alias x a x b
- list [catch {interp alias x b x a} msg] $msg
- } {1 {cannot define or rename alias "b": would create a loop}}
- test interp-17.4 {alias loop prevention} {
- catch {interp delete x}
- interp create x
- interp alias x b x a
- list [catch {x eval rename b a} msg] $msg
- } {1 {cannot define or rename alias "b": 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 "l2": 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.
- #
- if {[info commands testinterpdelete] == ""} {
- puts "This application hasn't been compiled with the "testinterpdelete""
- puts "command, so I can't test slave delete calls"
- } else {
- test interp-18.1 {testing Tcl_DeleteInterp vs slaves} {
- list [catch {testinterpdelete} msg] $msg
- } {1 {wrong # args: should be "testinterpdelete path"}}
- test interp-18.2 {testing Tcl_DeleteInterp vs slaves} {
- catch {interp delete a}
- interp create a
- testinterpdelete a
- } ""
- test interp-18.3 {testing Tcl_DeleteInterp vs slaves} {
- catch {interp delete a}
- interp create a
- interp create {a b}
- testinterpdelete {a b}
- } ""
- test interp-18.4 {testing Tcl_DeleteInterp vs slaves} {
- catch {interp delete a}
- interp create a
- interp create {a b}
- testinterpdelete a
- } ""
- test interp-18.5 {testing Tcl_DeleteInterp vs slaves} {
- 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} {
- 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} {knownBug} {
- 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 "zop"}
- 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
- 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} {
- catch {interp delete a}
- interp create a
- 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} {
- catch {interp delete a}
- interp create a
- 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]
- lappend l $msg
- a expose list
- lappend l [catch {a eval {list 1 2 3}} msg]
- lappend l $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} {
- catch {interp delete a}
- interp create a
- 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]
- lappend l $msg
- lappend l [catch {a invokehidden list 1 2 3} msg]
- lappend l $msg
- a expose list
- lappend l [catch {a eval {list 1 2 3}} msg]
- lappend l $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 {}} {
- catch {interp delete a}
- interp create a
- 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]
- lappend l $msg
- lappend l [catch {a invokehidden list {"" 1 2 3}} msg]
- lappend l $msg
- a expose list
- lappend l [catch {a eval {list 1 2 3}} msg]
- lappend l $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 {}} {
- catch {interp delete a}
- interp create a
- 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]
- lappend l $msg
- lappend l [catch {a invokehidden list {{} 1 2 3}} msg]
- lappend l $msg
- a expose list
- lappend l [catch {a eval {list 1 2 3}} msg]
- lappend l $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} {
- catch {interp delete a}
- interp create a
- a hide list
- set l ""
- set z 45
- lappend l [catch {a invokehidden list $z 1 2 3} msg]
- lappend l $msg
- a expose list
- lappend l [catch {a eval 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.7 {interp invokehidden vs variable eval} {
- catch {interp delete a}
- interp create a
- a hide list
- set z 45
- set l ""
- lappend l [catch {a invokehidden list {$z a b c}} msg]
- lappend l $msg
- interp delete a
- set l
- } {0 {{$z a b c}}}
- test interp-20.8 {interp invokehidden vs variable eval} {
- catch {interp delete a}
- interp create a
- a hide list
- a eval set z 89
- set z 45
- set l ""
- lappend l [catch {a invokehidden list {$z a b c}} msg]
- lappend l $msg
- interp delete a
- set l
- } {0 {{$z a b c}}}
- test interp-20.9 {interp invokehidden vs variable eval} {
- catch {interp delete a}
- interp create a
- 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]
- lappend l $msg
- interp delete a
- set l
- } {0 {45 {$z a b c}}}
- test interp-20.10 {interp hide, interp expose and interp invokehidden} {
- catch {interp delete a}
- interp create a
- 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} {
- catch {interp delete a}
- interp create a
- 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]
- lappend l $msg
- interp expose a list
- lappend l [catch {interp eval a {list 1 2 3}} msg]
- lappend l $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} {
- catch {interp delete a}
- interp create a
- 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]
- lappend l $msg
- lappend l [catch {interp invokehidden a list 1 2 3} msg]
- lappend l $msg
- interp expose a list
- lappend l [catch {interp eval a {list 1 2 3}} msg]
- lappend l $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 {}} {
- catch {interp delete a}
- interp create a
- 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]
- lappend l $msg
- lappend l [catch {interp invokehidden a list {"" 1 2 3}} msg]
- lappend l $msg
- interp expose a list
- lappend l [catch {interp eval a {list 1 2 3}} msg]
- lappend l $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 {}} {
- catch {interp delete a}
- interp create a
- 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]
- lappend l $msg
- lappend l [catch {interp invokehidden a list {{} 1 2 3}} msg]
- lappend l $msg
- interp expose a list
- lappend l [catch {a eval {list 1 2 3}} msg]
- lappend l $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-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} {
- set l ""
- lappend l [interp hidden]
- interp hide {} pwd
- lappend l [interp hidden]
- interp expose {} pwd
- lappend l [interp hidden]
- set l
- } {{} pwd {}}
- test interp-21.4 {interp hidden} {
- catch {interp delete a}
- interp create a
- set l [interp hidden a]
- interp delete a
- set l
- } ""
- test interp-21.5 {interp hidden} {
- catch {interp delete a}
- interp create -safe a
- set l [lsort [interp hidden a]]
- interp delete a
- set l
- } $hidden_cmds
- test interp-21.6 {interp hidden vs interp hide, interp expose} {
- catch {interp delete a}
- interp create a
- set l ""
- lappend l [interp hidden a]
- interp hide a pwd
- lappend l [interp hidden a]
- interp expose a pwd
- lappend l [interp hidden a]
- interp delete a
- set l
- } {{} pwd {}}
- test interp-21.7 {interp hidden} {
- catch {interp delete a}
- interp create a
- set l [a hidden]
- interp delete a
- set l
- } ""
- test interp-21.8 {interp hidden} {
- catch {interp delete a}
- interp create a -safe
- set l [lsort [a hidden]]
- interp delete a
- set l
- } $hidden_cmds
- test interp-21.9 {interp hidden vs interp hide, interp expose} {
- catch {interp delete a}
- interp create a
- set l ""
- lappend l [a hidden]
- a hide pwd
- lappend l [a hidden]
- a expose pwd
- lappend l [a hidden]
- interp delete a
- set l
- } {{} 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} {
- catch {interp delete a}
- interp create a
- set l ""
- lappend l [interp hidden a]
- a alias bar bar
- lappend l [interp aliases a]
- lappend l [interp hidden a]
- a hide bar
- lappend l [interp aliases a]
- lappend l [interp hidden a]
- a alias bar {}
- lappend l [interp aliases a]
- lappend l [interp hidden a]
- interp delete a
- set l
- } {{} bar {} bar bar {} {}}
- test interp-23.2 {testing hiding vs aliases} {unixOrPc} {
- catch {interp delete a}
- interp create a -safe
- set l ""
- lappend l [lsort [interp hidden a]]
- a alias bar bar
- lappend l [interp aliases a]
- lappend l [lsort [interp hidden a]]
- a hide bar
- lappend l [interp aliases a]
- lappend l [lsort [interp hidden a]]
- a alias bar {}
- lappend l [interp aliases a]
- lappend l [lsort [interp hidden a]]
- interp delete a
- set l
- } {{cd encoding exec exit fconfigure file glob load open pwd socket source} bar {cd encoding exec exit fconfigure file glob load open pwd socket source} bar {bar cd encoding exec exit fconfigure file glob load open pwd socket source} {} {cd encoding exec exit fconfigure file glob load open pwd socket source}}
- test interp-23.3 {testing hiding vs aliases} {macOnly} {
- catch {interp delete a}
- interp create a -safe
- set l ""
- lappend l [lsort [interp hidden a]]
- a alias bar bar
- lappend l [interp aliases a]
- lappend l [lsort [interp hidden a]]
- a hide bar
- lappend l [interp aliases a]
- lappend l [lsort [interp hidden a]]
- a alias bar {}
- lappend l [interp aliases a]
- lappend l [lsort [interp hidden a]]
- interp delete a
- set l
- } {{beep cd echo encoding exit fconfigure file glob load ls open pwd socket source} bar {beep cd echo encoding exit fconfigure file glob load ls open pwd socket source} bar {bar beep cd echo encoding exit fconfigure file glob load ls open pwd socket source} {} {beep cd echo encoding exit fconfigure file glob load ls open pwd socket source}}
- test interp-24.1 {result resetting on error} {
- catch {interp delete a}
- interp create a
- proc foo args {error $args}
- interp alias a foo {} foo
- set l [interp eval a {
- set l {}
- lappend l [catch {foo 1 2 3} msg]
- lappend l $msg
- lappend l [catch {foo 3 4 5} msg]
- lappend l $msg
- set l
- }]
- interp delete a
- set l
- } {1 {1 2 3} 1 {3 4 5}}
- test interp-24.2 {result resetting on error} {
- catch {interp delete a}
- interp create a -safe
- proc foo args {error $args}
- interp alias a foo {} foo
- set l [interp eval a {
- set l {}
- lappend l [catch {foo 1 2 3} msg]
- lappend l $msg
- lappend l [catch {foo 3 4 5} msg]
- lappend l $msg
- set l
- }]
- interp delete a
- set l
- } {1 {1 2 3} 1 {3 4 5}}
- test interp-24.3 {result resetting on error} {
- catch {interp delete a}
- interp create a
- interp create {a b}
- interp eval a {
- proc foo args {error $args}
- }
- interp alias {a b} foo a foo
- set l [interp eval {a b} {
- set l {}
- lappend l [catch {foo 1 2 3} msg]
- lappend l $msg
- lappend l [catch {foo 3 4 5} msg]
- lappend l $msg
- set l
- }]
- interp delete a
- set l
- } {1 {1 2 3} 1 {3 4 5}}
- test interp-24.4 {result resetting on error} {
- catch {interp delete a}
- interp create a -safe
- interp create {a b}
- interp eval a {
- proc foo args {error $args}
- }
- interp alias {a b} foo a foo
- set l [interp eval {a b} {
- set l {}
- lappend l [catch {foo 1 2 3} msg]
- lappend l $msg
- lappend l [catch {foo 3 4 5} msg]
- lappend l $msg
- set l
- }]
- interp delete a
- set l
- } {1 {1 2 3} 1 {3 4 5}}
- test interp-24.5 {result resetting on error} {
- catch {interp delete a}
- catch {interp delete b}
- interp create a
- interp create b
- interp eval a {
- proc foo args {error $args}
- }
- interp alias b foo a foo
- set l [interp eval b {
- set l {}
- lappend l [catch {foo 1 2 3} msg]
- lappend l $msg
- lappend l [catch {foo 3 4 5} msg]
- lappend l $msg
- set l
- }]
- interp delete a
- set l
- } {1 {1 2 3} 1 {3 4 5}}
- test interp-24.6 {result resetting on error} {
- catch {interp delete a}
- catch {interp delete b}
- interp create a -safe
- interp create b -safe
- interp eval a {
- proc foo args {error $args}
- }
- interp alias b foo a foo
- set l [interp eval b {
- set l {}
- lappend l [catch {foo 1 2 3} msg]
- lappend l $msg
- lappend l [catch {foo 3 4 5} msg]
- lappend l $msg
- set l
- }]
- interp delete a
- set l
- } {1 {1 2 3} 1 {3 4 5}}
- test interp-24.7 {result resetting on error} {
- catch {interp delete a}
- interp create a
- interp eval a {
- proc foo args {error $args}
- }
- set l {}
- lappend l [catch {interp eval a foo 1 2 3} msg]
- lappend l $msg
- lappend l [catch {interp eval a foo 3 4 5} msg]
- lappend l $msg
- interp delete a
- set l
- } {1 {1 2 3} 1 {3 4 5}}
- test interp-24.8 {result resetting on error} {
- catch {interp delete a}
- interp create a -safe
- interp eval a {
- proc foo args {error $args}
- }
- set l {}
- lappend l [catch {interp eval a foo 1 2 3} msg]
- lappend l $msg
- lappend l [catch {interp eval a foo 3 4 5} msg]
- lappend l $msg
- interp delete a
- set l
- } {1 {1 2 3} 1 {3 4 5}}
- test interp-24.9 {result resetting on error} {
- catch {interp delete a}
- 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
- }
- }
- set l {}
- lappend l [catch {interp eval a foo 1 2 3} msg]
- lappend l $msg
- lappend l [catch {interp eval a foo 3 4 5} msg]
- lappend l $msg
- interp delete a
- set l
- } {1 {1 2 3} 1 {3 4 5}}
- test interp-24.10 {result resetting on error} {
- catch {interp delete a}
- 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
- }
- }
- set l {}
- lappend l [catch {interp eval a foo 1 2 3} msg]
- lappend l $msg
- lappend l [catch {interp eval a foo 3 4 5} msg]
- lappend l $msg
- interp delete a
- set l
- } {1 {1 2 3} 1 {3 4 5}}
- test interp-24.11 {result resetting on error} {
- catch {interp delete a}
- interp create a
- interp create {a b}
- interp eval {a b} {
- proc foo args {error $args}
- }
- interp eval a {
- proc foo args {
- set l {}
- lappend l [catch {eval interp eval b foo $args} msg]
- lappend l $msg
- lappend l [catch {eval interp eval b foo $args} msg]
- lappend l $msg
- set l
- }
- }
- set l [interp eval a foo 1 2 3]
- interp delete a
- set l
- } {1 {1 2 3} 1 {1 2 3}}
- test interp-24.12 {result resetting on error} {
- catch {interp delete a}
- interp create a -safe
- interp create {a b}
- interp eval {a b} {
- proc foo args {error $args}
- }
- interp eval a {
- proc foo args {
- set l {}
- lappend l [catch {eval interp eval b foo $args} msg]
- lappend l $msg
- lappend l [catch {eval interp eval b foo $args} msg]
- lappend l $msg
- set l
- }
- }
- set l [interp eval a foo 1 2 3]
- interp delete a
- set l
- } {1 {1 2 3} 1 {1 2 3}}
- unset hidden_cmds
- test interp-25.1 {testing aliasing of string commands} {
- catch {interp delete a}
- interp create a
- a alias exec foo ;# Relies on exec being a string command!
- interp delete a
- } ""
- #
- # 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}
- {knownBug} {
- # The known bug is that the break and continue should raise errors
- # that they are used outside a loop.
- catch {interp delete a}
- interp create a
- set res {}
- interp eval a {proc retcode {code} {return -code $code ret$code}}
- interp hide a retcode
- for {set code -1} {$code<=5} {incr code} {
- lappend res [catch {interp invokehidden a retcode $code} msg] $msg
- }
- interp delete a
- set res
- } {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}
- test interp-26.6 {result code transmission: all combined--bug 1637}
- {knownBug} {
- # Test that all the possibles error codes from Tcl get passed
- # In both directions. This doesn't work.
- set interp [interp create];
- proc MyTestAlias {interp args} {
- global aliasTrace;
- lappend aliasTrace $args;
- eval interp invokehidden [list $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
- }
- interp delete $interp;
- set res
- } {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}
- # Some tests might need to be added to check for difference between
- # toplevel and non toplevel evals.
- # End of return code transmission section
- test interp-26.7 {errorInfo transmission: regular interps} {
- set interp [interp create];
- proc MyError {secret} {
- return -code error "msg"
- }
- proc MyTestAlias {interp args} {
- MyError "some secret"
- }
- interp alias $interp test {} MyTestAlias $interp;
- set res [interp eval $interp {catch test;set errorInfo}]
- interp delete $interp;
- set res
- } {msg
- while executing
- "MyError "some secret""
- (procedure "MyTestAlias" line 2)
- invoked from within
- "test"}
- test interp-26.8 {errorInfo transmission: safe interps--bug 1637} {knownBug} {
- # this test fails because the errorInfo is fully transmitted
- # whether the interp is safe or not. The errorInfo should never
- # report data from the master interpreter because it could
- # contain sensitive information.
- set interp [interp create -safe];
- proc MyError {secret} {
- return -code error "msg"
- }
- proc MyTestAlias {interp args} {
- MyError "some secret"
- }
- interp alias $interp test {} MyTestAlias $interp;
- set res [interp eval $interp {catch test;set errorInfo}]
- interp delete $interp;
- set res
- } {msg
- while executing
- "test"}
- # Interps & Namespaces
- test interp-27.1 {interp aliases & namespaces} {
- set i [interp create];
- set aliasTrace {};
- proc tstAlias {args} {
- global aliasTrace;
- lappend aliasTrace [list [namespace current] $args];
- }
- $i alias foo::bar tstAlias foo::bar;
- $i eval foo::bar test
- interp delete $i
- set aliasTrace;
- } {{:: {foo::bar test}}}
- test interp-27.2 {interp aliases & namespaces} {
- set i [interp create];
- set aliasTrace {};
- proc tstAlias {args} {
- global aliasTrace;
- lappend aliasTrace [list [namespace current] $args];
- }
- $i alias foo::bar tstAlias foo::bar;
- $i eval namespace eval foo {bar test}
- interp delete $i
- set aliasTrace;
- } {{:: {foo::bar test}}}
- test interp-27.3 {interp aliases & namespaces} {
- set i [interp create];
- set aliasTrace {};
- proc tstAlias {args} {
- global aliasTrace;
- lappend aliasTrace [list [namespace current] $args];
- }
- interp eval $i {namespace eval foo {proc bar {} {error "bar called"}}}
- interp alias $i foo::bar {} tstAlias foo::bar;
- interp eval $i {namespace eval foo {bar test}}
- interp delete $i
- set aliasTrace;
- } {{:: {foo::bar test}}}
- test interp-27.4 {interp aliases & namespaces} {
- set i [interp create];
- namespace eval foo2 {
- variable aliasTrace {};
- proc bar {args} {
- variable aliasTrace;
- lappend aliasTrace [list [namespace current] $args];
- }
- }
- $i alias foo::bar foo2::bar foo::bar;
- $i eval namespace eval foo {bar test}
- set r $foo2::aliasTrace;
- namespace delete foo2;
- set r
- } {{::foo2 {foo::bar test}}}
- # the following tests are commented out while we don't support
- # hiding in namespaces
- # test interp-27.5 {interp hidden & namespaces} {
- # set i [interp create];
- # interp eval $i {
- # namespace eval foo {
- # proc bar {args} {
- # return "bar called ([namespace current]) ($args)"
- # }
- # }
- # }
- # set res [list [interp eval $i {namespace eval foo {bar test1}}]]
- # interp hide $i foo::bar;
- # lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg]
- # interp delete $i;
- # set res;
- #} {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}}
- # test interp-27.6 {interp hidden & aliases & namespaces} {
- # set i [interp create];
- # set v root-master;
- # namespace eval foo {
- # variable v foo-master;
- # proc bar {interp args} {
- # variable v;
- # list "master bar called ($v) ([namespace current]) ($args)"
- # [interp invokehidden $interp foo::bar $args];
- # }
- # }
- # interp eval $i {
- # namespace eval foo {
- # namespace export *
- # variable v foo-slave;
- # proc bar {args} {
- # variable v;
- # return "slave bar called ($v) ([namespace current]) ($args)"
- # }
- # }
- # }
- # set res [list [interp eval $i {namespace eval foo {bar test1}}]]
- # $i hide foo::bar;
- # $i alias foo::bar foo::bar $i;
- # set res [concat $res [interp eval $i {
- # set v root-slave;
- # namespace eval test {
- # variable v foo-test;
- # namespace import ::foo::*;
- # bar test2
- # }
- # }]]
- # namespace delete foo;
- # interp delete $i;
- # set res
- # } {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}}
- # test interp-27.7 {interp hidden & aliases & imports & namespaces} {
- # set i [interp create];
- # set v root-master;
- # namespace eval mfoo {
- # variable v foo-master;
- # proc bar {interp args} {
- # variable v;
- # list "master bar called ($v) ([namespace current]) ($args)"
- # [interp invokehidden $interp test::bar $args];
- # }
- # }
- # interp eval $i {
- # namespace eval foo {
- # namespace export *
- # variable v foo-slave;
- # proc bar {args} {
- # variable v;
- # return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)"
- # }
- # }
- # set v root-slave;
- # namespace eval test {
- # variable v foo-test;
- # namespace import ::foo::*;
- # }
- # }
- # set res [list [interp eval $i {namespace eval test {bar test1}}]]
- # $i hide test::bar;
- # $i alias test::bar mfoo::bar $i;
- # set res [concat $res [interp eval $i {test::bar test2}]];
- # namespace delete mfoo;
- # interp delete $i;
- # set res
- # } {{slave bar called (foo-slave) (bar test1) (::tcltest) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}}
- #test interp-27.8 {hiding, namespaces and integrity} {
- # namespace eval foo {
- # variable v 3;
- # proc bar {} {variable v; set v}
- # # next command would currently generate an unknown command "bar" error.
- # interp hide {} bar;
- # }
- # namespace delete foo;
- # list [catch {interp invokehidden {} foo} msg] $msg;
- #} {1 {invalid hidden command name "foo"}}
- test interp-28.1 {getting fooled by slave's namespace ?} {
- set i [interp create -safe];
- proc master {interp args} {interp hide $interp list}
- $i alias master master $i;
- set r [interp eval $i {
- namespace eval foo {
- proc list {args} {
- return "dummy foo::list";
- }
- master;
- }
- info commands list
- }]
- interp delete $i;
- set r
- } {}
- # 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?)} 48}
- 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?)} 48}
- 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?)} 48}
- 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}
- test interp-29.3.7 {recursion limit error reporting} {
- interp create slave
- after 0 {interp recursionlimit slave 5}
- set r1 [slave eval {
- catch { # nesting level 1
- eval { # 2
- eval { # 3
- eval { # 4
- eval { # 5
- update
- set 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.8 {recursion limit error reporting} {
- interp create slave
- after 0 {interp recursionlimit slave 4}
- set r1 [slave eval {
- catch { # nesting level 1
- eval { # 2
- eval { # 3
- eval { # 4
- eval { # 5
- update
- 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.9 {recursion limit error reporting} {
- interp create slave
- after 0 {interp recursionlimit slave 6}
- set r1 [slave eval {
- catch { # nesting level 1
- eval { # 2
- eval { # 3
- 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.10 {recursion limit error reporting} {
- interp create slave
- after 0 {slave recursionlimit 4}
- set r1 [slave eval {
- catch { # nesting level 1
- eval { # 2
- eval { # 3
- eval { # 4
- eval { # 5
- update
- 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.11 {recursion limit error reporting} {
- interp create slave
- after 0 {slave recursionlimit 5}
- set r1 [slave eval {
- catch { # nesting level 1
- eval { # 2
- eval { # 3
- eval { # 4
- eval { # 5
- update
- set 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.12 {recursion limit error reporting} {
- interp create slave
- after 0 {slave recursionlimit 6}
- set r1 [slave eval {
- catch { # nesting level 1
- eval { # 2
- eval { # 3
- eval { # 4
- eval { # 5
- update
- set 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
- } 49
- 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
- } 49
- test interp-29.5.1 {does slave recursion limit affect master?} {
- set before [interp recursionlimit {}]
- set i [interp create]
- interp recursionlimit $i 20000
- set after [interp recursionlimit {}]
- set 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
- }
- catch {unset 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 } {
- cd [temporaryDirectory]
- 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
- cd [workingDirectory]
- expr {[string equal $parent $child] ? 1 :
- "{$parent} != {$child}"}
- } 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
- # cleanup
- foreach i [interp slaves] {
- interp delete $i
- }
- ::tcltest::cleanupTests
- return