summaryrefslogtreecommitdiffstats
path: root/tests/interp.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/interp.test')
-rw-r--r--tests/interp.test1240
1 files changed, 664 insertions, 576 deletions
diff --git a/tests/interp.test b/tests/interp.test
index 510ab4a..ad99fac 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -10,54 +10,56 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
+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 unload}
+set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload}
foreach i [interp slaves] {
interp delete $i
}
-
+
# Part 0: Check out options for interp command
-test interp-1.1 {options for interp command} {
- list [catch {interp} msg] $msg
-} {1 {wrong # args: should be "interp cmd ?arg ...?"}}
-test interp-1.2 {options for interp command} {
- list [catch {interp frobox} msg] $msg
-} {1 {bad option "frobox": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
+test interp-1.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} {
- 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-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} {
- list [catch {interp slaves foo bar zop} msg] $msg
-} {1 {wrong # args: should be "interp slaves ?path?"}}
-test interp-1.7 {options for interp command} {
- list [catch {interp hello} msg] $msg
-} {1 {bad option "hello": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
-test interp-1.8 {options for interp command} {
- list [catch {interp -froboz} msg] $msg
-} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
-test interp-1.9 {options for interp command} {
- list [catch {interp -froboz -safe} msg] $msg
-} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}}
-test interp-1.10 {options for interp command} {
- list [catch {interp target} msg] $msg
-} {1 {wrong # args: should be "interp target path alias"}}
-
+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} {
@@ -109,11 +111,11 @@ test interp-2.12 {anonymous interps vs existing procs} {
set x [interp create -safe]
regexp "interp(\[0-9]+)" $x dummy anothernum
expr $anothernum - $thenum
-} 1
+} 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
}
@@ -129,24 +131,24 @@ test interp-3.2 {testing interp exists and interp slaves} {
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.4 {testing interp exists and interp slaves} -body {
+ interp slaves a b c
+} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"}
+test interp-3.5 {testing interp exists and interp slaves} -body {
+ interp exists a b c
+} -returnCodes error -result {wrong # args: should be "interp exists ?path?"}
test interp-3.6 {testing interp exists and interp slaves} {
interp exists
} 1
test interp-3.7 {testing interp exists and interp slaves} {
interp slaves
} a
-test interp-3.8 {testing interp exists and interp slaves} {
- list [catch {interp slaves a b c} msg] $msg
-} {1 {wrong # args: should be "interp slaves ?path?"}}
+test interp-3.8 {testing interp exists and interp slaves} -body {
+ interp slaves a b c
+} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"}
test interp-3.9 {testing interp exists and interp slaves} {
interp create {a a2} -safe
- expr {[lsearch [interp slaves a] a2] >= 0}
+ expr {"a2" in [interp slaves a]}
} 1
test interp-3.10 {testing interp exists and interp slaves} {
interp exists {a a2}
@@ -160,12 +162,12 @@ 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.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
} ""
@@ -173,7 +175,7 @@ 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}
+ expr {"x1" in [interp slaves a]}
} 0
test interp-4.6 {testing interp delete} {
interp create c1
@@ -181,14 +183,14 @@ test interp-4.6 {testing interp delete} {
interp create c3
interp delete c1 c2 c3
} ""
-test interp-4.7 {testing interp delete} {
+test interp-4.7 {testing interp delete} -returnCodes error -body {
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}}
+ 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
@@ -213,9 +215,9 @@ interp create a
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.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
@@ -223,15 +225,14 @@ test interp-6.3 {testing eval} {
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"}}
+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} {
@@ -255,9 +256,9 @@ test interp-7.4 {testing basic alias creation} {
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"}}
+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} {
@@ -270,10 +271,10 @@ test interp-8.2 {testing basic alias invocation} {
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} {
+test interp-8.3 {testing basic alias invocation} -returnCodes error -body {
catch {interp create a}
- list [catch {a alias} msg] $msg
-} {1 {wrong # args: should be "a alias aliasName ?targetName? ?args..?"}}
+ 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} {
@@ -431,83 +432,74 @@ test interp-11.7 {testing interp target} {
test interp-12.1 {testing interp issafe} {
interp issafe
} 0
-test interp-12.2 {testing interp issafe} -setup {
+test interp-12.2 {testing interp issafe} {
catch {interp delete a}
-} -body {
interp create a
interp issafe a
-} -result 0
-test interp-12.3 {testing interp issafe} -setup {
+} 0
+test interp-12.3 {testing interp issafe} {
catch {interp delete a}
-} -body {
interp create a
interp create {a x3} -safe
interp issafe {a x3}
-} -result 1
-test interp-12.4 {testing interp issafe} -setup {
+} 1
+test interp-12.4 {testing interp issafe} {
catch {interp delete a}
-} -body {
interp create a
interp create {a x3} -safe
interp create {a x3 foo}
interp issafe {a x3 foo}
-} -result 1
+} 1
# Part 12: testing interpreter object command "issafe" sub-command
-test interp-13.1 {testing foo issafe} -setup {
+test interp-13.1 {testing foo issafe} {
catch {interp delete a}
-} -body {
interp create a
a issafe
-} -result 0
-test interp-13.2 {testing foo issafe} -setup {
+} 0
+test interp-13.2 {testing foo issafe} {
catch {interp delete a}
-} -body {
interp create a
interp create {a x3} -safe
a eval x3 issafe
-} -result 1
-test interp-13.3 {testing foo issafe} -setup {
+} 1
+test interp-13.3 {testing foo issafe} {
catch {interp delete a}
-} -body {
interp create a
interp create {a x3} -safe
interp create {a x3 foo}
a eval x3 eval foo issafe
-} -result 1
-test interp-13.4 {testing issafe arg checking} -body {
+} 1
+test interp-13.4 {testing issafe arg checking} {
catch {interp create a}
- a issafe too many args
-} -returnCodes error -result {wrong # args: should be "a issafe"}
+ 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} -setup {
+test interp-14.2 {testing interp aliases} {
catch {interp delete a}
-} -body {
interp create a
a alias a1 puts
a alias a2 puts
a alias a3 puts
lsort [interp aliases a]
-} -result {a1 a2 a3}
-test interp-14.3 {testing interp aliases} -setup {
+} {a1 a2 a3}
+test interp-14.3 {testing interp aliases} {
catch {interp delete a}
-} -body {
interp create a
interp create {a x3}
interp alias {a x3} froboz "" puts
interp aliases {a x3}
-} -result froboz
-test interp-14.4 {testing interp alias - alias over master} -setup {
- catch {interp delete a}
-} -body {
+} 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]
-} -result {1 {cannot define or rename alias "a": interpreter deleted} {}}
+} {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
@@ -595,7 +587,6 @@ test interp-14.10 {testing interp-alias: error messages} -setup {
invoked from within
"a 1"}
-
# part 15: testing file sharing
test interp-15.1 {testing file sharing} {
catch {interp delete z}
@@ -676,8 +667,7 @@ test interp-15.8 {testing file transferring} -body {
# Torture tests for interpreter deletion order
#
proc kill {} {interp delete xxx}
-
-test interp-15.9 {testing deletion order} {
+test interp-16.0 {testing deletion order} {
catch {interp delete xxx}
interp create xxx
xxx alias kill kill
@@ -1601,7 +1591,28 @@ test interp-20.49 {interp invokehidden -namespace} -setup {
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 {}
@@ -1609,67 +1620,73 @@ test interp-21.1 {interp hidden} {
test interp-21.2 {interp hidden} {
interp hidden
} ""
-test interp-21.3 {interp hidden vs interp hide, interp expose} {
+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]
- set l
-} {{} pwd {}}
-test interp-21.4 {interp hidden} {
+} -result {{} pwd {}}
+test interp-21.4 {interp hidden} -setup {
catch {interp delete a}
+} -body {
interp create a
- set l [interp hidden a]
+ interp hidden a
+} -cleanup {
interp delete a
- set l
-} ""
-test interp-21.5 {interp hidden} {
+} -result ""
+test interp-21.5 {interp hidden} -setup {
catch {interp delete a}
+} -body {
interp create -safe a
- set l [lsort [interp hidden a]]
+ lsort [interp hidden a]
+} -cleanup {
interp delete a
- set l
-} $hidden_cmds
-test interp-21.6 {interp hidden vs interp hide, interp expose} {
+} -result $hidden_cmds
+test interp-21.6 {interp hidden vs interp hide, interp expose} -setup {
catch {interp delete a}
- interp create 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
- set l
-} {{} pwd {}}
-test interp-21.7 {interp hidden} {
+} -result {{} pwd {}}
+test interp-21.7 {interp hidden} -setup {
catch {interp delete a}
+} -body {
interp create a
- set l [a hidden]
+ a hidden
+} -cleanup {
interp delete a
- set l
-} ""
-test interp-21.8 {interp hidden} {
+} -result ""
+test interp-21.8 {interp hidden} -setup {
catch {interp delete a}
+} -body {
interp create a -safe
- set l [lsort [a hidden]]
+ lsort [a hidden]
+} -cleanup {
interp delete a
- set l
-} $hidden_cmds
-test interp-21.9 {interp hidden vs interp hide, interp expose} {
+} -result $hidden_cmds
+test interp-21.9 {interp hidden vs interp hide, interp expose} -setup {
catch {interp delete a}
- interp create 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
- set l
-} {{} pwd {}}
+} -result {{} pwd {}}
test interp-22.1 {testing interp marktrusted} {
catch {interp delete a}
@@ -1769,183 +1786,161 @@ test interp-22.9 {testing interp marktrusted} {
set l
} {1 1 1 0 0}
-test interp-23.1 {testing hiding vs aliases} {
+test interp-23.1 {testing hiding vs aliases: unsafe interp} -setup {
catch {interp delete a}
- interp create a
set l ""
+} -body {
+ interp create a
lappend l [interp hidden a]
a alias bar bar
- lappend l [interp aliases a]
- lappend l [interp hidden a]
+ lappend l [interp aliases a] [interp hidden a]
a hide bar
- lappend l [interp aliases a]
- lappend l [interp hidden a]
+ lappend l [interp aliases a] [interp hidden a]
a alias bar {}
- lappend l [interp aliases a]
- lappend l [interp hidden a]
+ lappend l [interp aliases a] [interp hidden a]
+} -cleanup {
interp delete a
- set l
-} {{} bar {} bar bar {} {}}
-test interp-23.2 {testing hiding vs aliases} {unixOrPc} {
+} -result {{} bar {} bar bar {} {}}
+test interp-23.2 {testing hiding vs aliases: safe interp} -setup {
catch {interp delete a}
- interp create a -safe
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]]
- lappend l [lsort [interp hidden a]]
+ lappend l [lsort [interp aliases a]] [lsort [interp hidden a]]
a hide bar
- lappend l [lsort [interp aliases a]]
- lappend l [lsort [interp hidden a]]
+ lappend l [lsort [interp aliases a]] [lsort [interp hidden a]]
a alias bar {}
- lappend l [lsort [interp aliases a]]
- lappend l [lsort [interp hidden a]]
+ lappend l [lsort [interp aliases a]] [lsort [interp hidden a]]
+} -cleanup {
interp delete a
- set l
-} {{cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {bar cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload}}
+} -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} {
+test interp-24.1 {result resetting on error} -setup {
catch {interp delete a}
+} -body {
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 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
- rename foo {}
- set l
-} {1 {1 2 3} 1 {3 4 5}}
-test interp-24.2 {result resetting on error} {
+} -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
- 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 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
- rename foo {}
- set l
-} {1 {1 2 3} 1 {3 4 5}}
-test interp-24.3 {result resetting on error} {
+} -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
- 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 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
- set l
-} {1 {1 2 3} 1 {3 4 5}}
-test interp-24.4 {result resetting on error} {
+} -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
- set l [interp eval {a b} {
- set l {}
+ 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
- set l
- }]
+ }
+} -cleanup {
interp delete a
- set l
-} {1 {1 2 3} 1 {3 4 5}}
-test interp-24.5 {result resetting on error} {
+} -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
- 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 eval b {
+ lappend l [catch {foo 1 2 3} msg] $msg
+ lappend l [catch {foo 3 4 5} msg] $msg
+ }
+} -cleanup {
interp delete a
- set l
-} {1 {1 2 3} 1 {3 4 5}}
-test interp-24.6 {result resetting on error} {
+ 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
- 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 eval b {
+ lappend l [catch {foo 1 2 3} msg] $msg
+ lappend l [catch {foo 3 4 5} msg] $msg
+ }
+} -cleanup {
interp delete a
- set l
-} {1 {1 2 3} 1 {3 4 5}}
-test interp-24.7 {result resetting on error} {
+ 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}
}
- 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
+ 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
- set l
-} {1 {1 2 3} 1 {3 4 5}}
-test interp-24.8 {result resetting on error} {
+} -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}
}
- 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
+ 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
- set l
-} {1 {1 2 3} 1 {3 4 5}}
-test interp-24.9 {result resetting on error} {
+} -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} {
@@ -1956,16 +1951,15 @@ test interp-24.9 {result resetting on error} {
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
+ 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
- set l
-} {1 {1 2 3} 1 {3 4 5}}
-test interp-24.10 {result resetting on error} {
+} -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} {
@@ -1976,16 +1970,14 @@ test interp-24.10 {result resetting on error} {
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
+ 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
- set l
-} {1 {1 2 3} 1 {3 4 5}}
-test interp-24.11 {result resetting on error} {
+} -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} {
@@ -1993,20 +1985,17 @@ test interp-24.11 {result resetting on error} {
}
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
+ lappend l [catch {eval interp eval b foo $args} msg] $msg
+ lappend l [catch {eval interp eval b foo $args} msg] $msg
}
}
- set l [interp eval a foo 1 2 3]
+ interp eval a foo 1 2 3
+} -cleanup {
interp delete a
- set l
-} {1 {1 2 3} 1 {1 2 3}}
-test interp-24.12 {result resetting on error} {
+} -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} {
@@ -2014,28 +2003,22 @@ test interp-24.12 {result resetting on error} {
}
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
+ lappend l [catch {eval interp eval b foo $args} msg] $msg
+ lappend l [catch {eval interp eval b foo $args} msg] $msg
}
}
- set l [interp eval a foo 1 2 3]
+ interp eval a foo 1 2 3
+} -cleanup {
interp delete a
- set l
-} {1 {1 2 3} 1 {1 2 3}}
-
-unset hidden_cmds
+} -result {1 {1 2 3} 1 {1 2 3}}
-test interp-25.1 {testing aliasing of string commands} {
+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
@@ -2045,7 +2028,6 @@ 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 {}
@@ -2056,8 +2038,6 @@ test interp-26.1 {result code transmission : interp eval direct} {
interp delete a
set res
} {-1 0 1 2 3 4 5}
-
-
test interp-26.2 {result code transmission : interp eval indirect} {
# retcode == 2 == return is special
catch {interp delete a}
@@ -2071,12 +2051,10 @@ test interp-26.2 {result code transmission : interp eval indirect} {
interp delete a
set res
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}
-
test interp-26.3 {result code transmission : aliases} {
- # Test that all the possibles error codes from Tcl get passed up
- # from the slave interp's context to the master, even though the
- # slave nominally thinks the command is running at the root level.
-
+ # Test that all the possibles error codes from Tcl get passed up from the
+ # slave interp's context to the master, even though the slave nominally
+ # thinks the command is running at the root level.
catch {interp delete a}
interp create a
set res {}
@@ -2090,7 +2068,6 @@ test interp-26.3 {result code transmission : aliases} {
interp delete a
set res
} {-1 0 1 2 3 4 5}
-
test interp-26.4 {result code transmission: invoke hidden direct--bug 1637} \
{knownBug} {
# The known bug is that code 2 is returned, not the -code argument
@@ -2104,36 +2081,35 @@ test interp-26.4 {result code transmission: invoke hidden direct--bug 1637} \
interp delete a
set res
} {-1 0 1 2 3 4 5}
-
-test interp-26.5 {result code transmission: invoke hidden indirect--bug 1637} \
- {knownBug} {
- # The known bug is that the break and continue should raise errors
- # that they are used outside a loop.
+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
- 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];
+} -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;
+ global aliasTrace
+ lappend aliasTrace $args
interp invokehidden $interp {*}$args
}
foreach c {return} {
- interp hide $interp $c;
- interp alias $interp $c {} MyTestAlias $interp $c;
+ interp hide $interp $c
+ interp alias $interp $c {} MyTestAlias $interp $c
}
interp eval $interp {proc ret {code} {return -code $code ret$code}}
set res {}
@@ -2141,248 +2117,247 @@ test interp-26.6 {result code transmission: all combined--bug 1637} \
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.
-
+ 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} {
- set interp [interp create];
+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;
- set res [interp eval $interp {catch test;set ::errorInfo}]
- interp delete $interp;
- set res
-} {msg
+ 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} {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];
+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;
- set res [interp eval $interp {catch test;set ::errorInfo}]
- interp delete $interp;
- set res
-} {msg
+ 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} {
- set i [interp create];
- set aliasTrace {};
+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];
+ global aliasTrace
+ lappend aliasTrace [list [namespace current] $args]
}
- $i alias foo::bar tstAlias foo::bar;
+ $i alias foo::bar tstAlias foo::bar
$i eval foo::bar test
+ return $aliasTrace
+} -cleanup {
interp delete $i
- set aliasTrace;
-} {{:: {foo::bar test}}}
-
-test interp-27.2 {interp aliases & namespaces} {
- set i [interp create];
- set aliasTrace {};
+} -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];
+ global aliasTrace
+ lappend aliasTrace [list [namespace current] $args]
}
- $i alias foo::bar tstAlias foo::bar;
+ $i alias foo::bar tstAlias foo::bar
$i eval namespace eval foo {bar test}
+ return $aliasTrace
+} -cleanup {
interp delete $i
- set aliasTrace;
-} {{:: {foo::bar test}}}
-
-test interp-27.3 {interp aliases & namespaces} {
- set i [interp create];
- set aliasTrace {};
+} -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];
+ global aliasTrace
+ lappend aliasTrace [list [namespace current] $args]
}
interp eval $i {namespace eval foo {proc bar {} {error "bar called"}}}
- interp alias $i foo::bar {} tstAlias foo::bar;
+ interp alias $i foo::bar {} tstAlias foo::bar
interp eval $i {namespace eval foo {bar test}}
+ return $aliasTrace
+} -cleanup {
interp delete $i
- set aliasTrace;
-} {{:: {foo::bar test}}}
-
-test interp-27.4 {interp aliases & namespaces} {
- set i [interp create];
+} -result {{:: {foo::bar test}}}
+test interp-27.4 {interp aliases & namespaces} -setup {
+ set i [interp create]
+} -body {
namespace eval foo2 {
- variable aliasTrace {};
+ variable aliasTrace {}
proc bar {args} {
- variable aliasTrace;
- lappend aliasTrace [list [namespace current] $args];
+ variable aliasTrace
+ lappend aliasTrace [list [namespace current] $args]
}
}
- $i alias foo::bar foo2::bar foo::bar;
+ $i alias foo::bar foo2::bar foo::bar
$i eval namespace eval foo {bar test}
- 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];
+ 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}
- $i alias master master $i;
+} -body {
+ $i alias master master $i
set r [interp eval $i {
namespace eval foo {
proc list {args} {
- return "dummy foo::list";
+ return "dummy foo::list"
}
- master;
+ master
}
info commands list
}]
- interp delete $i;
- set r
-} {}
-
-test interp-28.2 {master's nsName cache should not cross} {
+} -cleanup {
+ rename master {}
+ interp delete $i
+} -result {}
+test interp-28.2 {master's nsName cache should not cross} -setup {
set i [interp create]
- set res [$i eval {
+ $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 [{*}$y]
+ namespace delete {*}[filter [{*}$y]]
set j [interp create]
- $j eval {namespace delete {*}[namespace children ::]}
+ $j alias filter filter
+ $j eval {namespace delete {*}[filter [namespace children ::]]}
namespace eval foo {}
- set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]]
- interp delete $j
- set res
- }]
+ list [filter [eval $x]] [filter [eval $y]] [filter [$j eval $x]] [filter [$j eval $y]]
+ }
+} -cleanup {
interp delete $i
- set res
-} {::foo ::foo {} {}}
+} -result {::foo ::foo {} {}}
# Part 29: recursion limit
# 29.1.* Argument checking
@@ -2395,96 +2370,81 @@ test interp-28.2 {master's nsName cache should not cross} {
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 {
@@ -2495,7 +2455,6 @@ test interp-29.2.4 {query recursion limit} {
interp delete $i
set r
} {42 42}
-
test interp-29.2.5 {query recursion limit} {
set i [interp create]
set n1 [interp recursionlimit $i 42]
@@ -2503,7 +2462,6 @@ test interp-29.2.5 {query recursion limit} {
interp delete $i
list $n1 $n2
} {42 42}
-
test interp-29.2.6 {query recursion limit} {
set i [interp create]
set n1 [interp recursionlimit $i 42]
@@ -2511,7 +2469,6 @@ test interp-29.2.6 {query recursion limit} {
interp delete $i
list $n1 $n2
} {42 42}
-
test interp-29.2.7 {query recursion limit} {
set i [interp create]
set n1 [$i recursionlimit 42]
@@ -2519,7 +2476,6 @@ test interp-29.2.7 {query recursion limit} {
interp delete $i
list $n1 $n2
} {42 42}
-
test interp-29.2.8 {query recursion limit} {
set i [interp create]
set n1 [$i recursionlimit 42]
@@ -2527,7 +2483,6 @@ test interp-29.2.8 {query recursion limit} {
interp delete $i
list $n1 $n2
} {42 42}
-
test interp-29.3.1 {recursion limit} {
set i [interp create]
set r [interp eval $i {
@@ -2538,8 +2493,7 @@ test interp-29.3.1 {recursion limit} {
}]
interp delete $i
set r
-} {1 {too many nested evaluations (infinite loop?)} 48}
-
+} {1 {too many nested evaluations (infinite loop?)} 49}
test interp-29.3.2 {recursion limit} {
set i [interp create]
interp recursionlimit $i 50
@@ -2550,8 +2504,7 @@ test interp-29.3.2 {recursion limit} {
}]
interp delete $i
set r
-} {1 {too many nested evaluations (infinite loop?)} 48}
-
+} {1 {too many nested evaluations (infinite loop?)} 49}
test interp-29.3.3 {recursion limit} {
set i [interp create]
$i recursionlimit 50
@@ -2562,8 +2515,7 @@ test interp-29.3.3 {recursion limit} {
}]
interp delete $i
set r
-} {1 {too many nested evaluations (infinite loop?)} 48}
-
+} {1 {too many nested evaluations (infinite loop?)} 49}
test interp-29.3.4 {recursion limit error reporting} {
interp create slave
set r1 [slave eval {
@@ -2584,7 +2536,6 @@ test interp-29.3.4 {recursion limit error reporting} {
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 {
@@ -2605,7 +2556,6 @@ test interp-29.3.5 {recursion limit error reporting} {
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 {
@@ -2626,8 +2576,11 @@ test interp-29.3.6 {recursion limit error reporting} {
interp delete slave
list $r1 $r2
} {0 ok}
-
-test interp-29.3.7 {recursion limit error reporting} {
+#
+# 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 {
@@ -2636,8 +2589,51 @@ test interp-29.3.7 {recursion limit error reporting} {
eval { # 3
eval { # 4
eval { # 5
- update
- set x ok
+ 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
}
}
}
@@ -2648,8 +2644,7 @@ test interp-29.3.7 {recursion limit error reporting} {
interp delete slave
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
-
-test interp-29.3.8 {recursion limit error reporting} {
+test interp-29.3.8a {recursion limit error reporting} {
interp create slave
after 0 {interp recursionlimit slave 4}
set r1 [slave eval {
@@ -2658,8 +2653,29 @@ test interp-29.3.8 {recursion limit error reporting} {
eval { # 3
eval { # 4
eval { # 5
- update
- set x ok
+ 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
}
}
}
@@ -2670,8 +2686,7 @@ test interp-29.3.8 {recursion limit error reporting} {
interp delete slave
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
-
-test interp-29.3.9 {recursion limit error reporting} {
+test interp-29.3.9a {recursion limit error reporting} {
interp create slave
after 0 {interp recursionlimit slave 6}
set r1 [slave eval {
@@ -2680,8 +2695,8 @@ test interp-29.3.9 {recursion limit error reporting} {
eval { # 3
eval { # 4
eval { # 5
- update
- set x ok
+ update
+ set x ok
}
}
}
@@ -2692,8 +2707,28 @@ test interp-29.3.9 {recursion limit error reporting} {
interp delete slave
list $r1 $r2
} {0 ok}
-
-test interp-29.3.10 {recursion limit error reporting} {
+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 {
@@ -2713,9 +2748,29 @@ test interp-29.3.10 {recursion limit error reporting} {
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.11 {recursion limit error reporting} {
+test interp-29.3.11a {recursion limit error reporting} {
interp create slave
after 0 {slave recursionlimit 5}
set r1 [slave eval {
@@ -2724,8 +2779,30 @@ test interp-29.3.11 {recursion limit error reporting} {
eval { # 3
eval { # 4
eval { # 5
- update
- set x ok
+ 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
}
}
}
@@ -2736,8 +2813,7 @@ test interp-29.3.11 {recursion limit error reporting} {
interp delete slave
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
-
-test interp-29.3.12 {recursion limit error reporting} {
+test interp-29.3.12a {recursion limit error reporting} {
interp create slave
after 0 {slave recursionlimit 6}
set r1 [slave eval {
@@ -2746,8 +2822,30 @@ test interp-29.3.12 {recursion limit error reporting} {
eval { # 3
eval { # 4
eval { # 5
- update
- set x ok
+ 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
}
}
}
@@ -2758,7 +2856,6 @@ test interp-29.3.12 {recursion limit error reporting} {
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 {
@@ -2773,8 +2870,7 @@ test interp-29.4.1 {recursion limit inheritance} {
}]
interp delete $i
set r
-} 49
-
+} 50
test interp-29.4.2 {recursion limit inheritance} {
set i [interp create]
$i recursionlimit 50
@@ -2787,8 +2883,7 @@ test interp-29.4.2 {recursion limit inheritance} {
}]
interp delete $i
set r
-} 49
-
+} 50
test interp-29.5.1 {does slave recursion limit affect master?} {
set before [interp recursionlimit {}]
set i [interp create]
@@ -2798,7 +2893,6 @@ test interp-29.5.1 {does slave recursion limit affect master?} {
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]
@@ -2808,7 +2902,6 @@ test interp-29.5.2 {does slave recursion limit affect master?} {
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]
@@ -2818,7 +2911,6 @@ test interp-29.5.3 {does slave recursion limit affect master?} {
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]
@@ -2828,21 +2920,18 @@ test interp-29.5.4 {does slave recursion limit affect master?} {
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]
@@ -2850,7 +2939,6 @@ test interp-29.6.3 {safe interpreter recursion limit} {
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]
@@ -2858,7 +2946,6 @@ test interp-29.6.4 {safe interpreter recursion limit} {
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]
@@ -2866,7 +2953,6 @@ test interp-29.6.5 {safe interpreter recursion limit} {
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]
@@ -2874,7 +2960,6 @@ test interp-29.6.6 {safe interpreter recursion limit} {
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]
@@ -2882,14 +2967,12 @@ test interp-29.6.7 {safe interpreter recursion limit} {
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 [
@@ -2904,7 +2987,6 @@ test interp-29.6.9 {safe interpreter recursion limit} {
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 [
@@ -2957,13 +3039,12 @@ test interp-31.1 {alias invocation scope} {
upvar 1 $varName localVar
set localVar $value
}
-
interp alias {} myNewSet {} mySet
proc testMyNewSet {value} {
myNewSet a $value
return $a
}
- catch {unset a}
+ unset -nocomplain a
set result [testMyNewSet "ok"]
rename testMyNewSet {}
rename mySet {}
@@ -2971,8 +3052,9 @@ test interp-31.1 {alias invocation scope} {
set result
} ok
-test interp-32.1 {parent's working directory should be inherited by a child interp} {
+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]
@@ -2985,10 +3067,11 @@ test interp-32.1 {parent's working directory should be inherited by a child inte
cd ..
file delete cwd_test
interp delete $i
- cd [workingDirectory]
expr {[string equal $parent $child] ? 1 :
"\{$parent\} != \{$child\}"}
-} 1
+} -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.
@@ -3297,10 +3380,10 @@ test interp-34.13 {time limit granularity and vwait: Bug 2891362} -setup {
test interp-35.1 {interp limit syntax} -body {
interp limit
-} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"}
+} -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 ?options?"}
+} -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}
@@ -3471,27 +3554,26 @@ test interp-36.6 {SlaveBgerror returns handler} -setup {
} -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]
+ 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]
+ 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 result
+ unset -nocomplain result
interp delete slave
} -result foo
@@ -3504,7 +3586,7 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup {
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 result
+ unset -nocomplain result
interp delete a
} -result {26 26}
@@ -3525,7 +3607,7 @@ test interp-38.2 {interp debug env var} -setup {
} -body {
interp debug a
} -cleanup {
- unset ::env(TCL_INTERP_DEBUG_FRAME)
+ unset -nocomplain ::env(TCL_INTERP_DEBUG_FRAME)
interp delete a
} -result {-frame 1}
test interp-38.3 {interp debug wrong args} -body {
@@ -3550,10 +3632,16 @@ test interp-38.8 {interp debug basic setup} -body {
} -returnCodes {
error
} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
-
+
# cleanup
+unset -nocomplain hidden_cmds
foreach i [interp slaves] {
interp delete $i
}
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End: