riscv
/
OpenFPGA
mirror of https://github.com/lnis-uofu/OpenFPGA.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
OpenFPGA/libs/EXTERNAL/tcl8.6.12/tests/interp.test

3680 lines
102 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

# This file tests the multiple interpreter facility of Tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testinterpdelete [llength [info commands testinterpdelete]]
set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload}
foreach i [interp children] {
interp delete $i
}
# Part 0: Check out options for interp command
test interp-1.1 {options for interp command} -returnCodes error -body {
interp
} -result {wrong # args: should be "interp cmd ?arg ...?"}
test interp-1.2 {options for interp command} -returnCodes error -body {
interp frobox
} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
test interp-1.3 {options for interp command} {
interp delete
} ""
test interp-1.4 {options for interp command} -returnCodes error -body {
interp delete foo bar
} -result {could not find interpreter "foo"}
test interp-1.5 {options for interp command} -returnCodes error -body {
interp exists foo bar
} -result {wrong # args: should be "interp exists ?path?"}
#
# test interp-0.6 was removed
#
test interp-1.6 {options for interp command} -returnCodes error -body {
interp children foo bar zop
} -result {wrong # args: should be "interp children ?path?"}
test interp-1.7 {options for interp command} -returnCodes error -body {
interp hello
} -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, 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, children, 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, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
test interp-1.10 {options for interp command} -returnCodes error -body {
interp target
} -result {wrong # args: should be "interp target path alias"}
# Part 1: Basic interpreter creation tests:
test interp-2.1 {basic interpreter creation} {
interp create a
} a
test interp-2.2 {basic interpreter creation} {
catch {interp create}
} 0
test interp-2.3 {basic interpreter creation} {
catch {interp create -safe}
} 0
test interp-2.4 {basic interpreter creation} -setup {
catch {interp create a}
} -returnCodes error -body {
interp create a
} -result {interpreter named "a" already exists, cannot create}
test interp-2.5 {basic interpreter creation} {
interp create b -safe
} b
test interp-2.6 {basic interpreter creation} {
interp create d -safe
} d
test interp-2.7 {basic interpreter creation} {
list [catch {interp create -froboz} msg] $msg
} {1 {bad option "-froboz": must be -safe or --}}
test interp-2.8 {basic interpreter creation} {
interp create -- -froboz
} -froboz
test interp-2.9 {basic interpreter creation} {
interp create -safe -- -froboz1
} -froboz1
test interp-2.10 {basic interpreter creation} -setup {
catch {interp create a}
} -body {
interp create {a x1}
interp create {a x2}
interp create {a x3} -safe
} -result {a x3}
test interp-2.11 {anonymous interps vs existing procs} {
set x [interp create]
regexp "interp(\[0-9]+)" $x dummy thenum
interp delete $x
proc interp$thenum {} {}
set x [interp create]
regexp "interp(\[0-9]+)" $x dummy anothernum
expr {$anothernum > $thenum}
} 1
test interp-2.12 {anonymous interps vs existing procs} {
set x [interp create -safe]
regexp "interp(\[0-9]+)" $x dummy thenum
interp delete $x
proc interp$thenum {} {}
set x [interp create -safe]
regexp "interp(\[0-9]+)" $x dummy anothernum
expr {$anothernum - $thenum}
} 1
test interp-2.13 {correct default when no $path arg is given} -body {
interp create --
} -match regexp -result {interp[0-9]+}
foreach i [interp children] {
interp delete $i
}
# Part 2: Testing "interp children" and "interp exists"
test interp-3.1 {testing interp exists and interp children} {
interp children
} ""
test interp-3.2 {testing interp exists and interp children} {
interp create a
interp exists a
} 1
test interp-3.3 {testing interp exists and interp children} {
interp exists nonexistent
} 0
test interp-3.4 {testing interp exists and interp children} -body {
interp children a b c
} -returnCodes error -result {wrong # args: should be "interp children ?path?"}
test interp-3.5 {testing interp exists and interp children} -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 children} {
interp exists
} 1
test interp-3.7 {testing interp exists and interp children} -setup {
catch {interp create a}
} -body {
interp children
} -result a
test interp-3.8 {testing interp exists and interp children} -body {
interp children a b c
} -returnCodes error -result {wrong # args: should be "interp children ?path?"}
test interp-3.9 {testing interp exists and interp children} -setup {
catch {interp create a}
} -body {
interp create {a a2} -safe
expr {"a2" in [interp children a]}
} -result 1
test interp-3.10 {testing interp exists and interp children} -setup {
catch {interp create a}
catch {interp create {a a2}}
} -body {
interp exists {a a2}
} -result 1
# Part 3: Testing "interp delete"
test interp-3.11 {testing interp delete} {
interp delete
} ""
test interp-4.1 {testing interp delete} {
catch {interp create a}
interp delete a
} ""
test interp-4.2 {testing interp delete} -returnCodes error -body {
interp delete nonexistent
} -result {could not find interpreter "nonexistent"}
test interp-4.3 {testing interp delete} -returnCodes error -body {
interp delete x y z
} -result {could not find interpreter "x"}
test interp-4.4 {testing interp delete} {
interp delete
} ""
test interp-4.5 {testing interp delete} {
interp create a
interp create {a x1}
interp delete {a x1}
expr {"x1" in [interp children a]}
} 0
test interp-4.6 {testing interp delete} {
interp create c1
interp create c2
interp create c3
interp delete c1 c2 c3
} ""
test interp-4.7 {testing interp delete} -returnCodes error -body {
interp create c1
interp create c2
interp delete c1 c2 c3
} -result {could not find interpreter "c3"}
test interp-4.8 {testing interp delete} -returnCodes error -body {
interp delete {}
} -result {cannot delete the current interpreter}
foreach i [interp children] {
interp delete $i
}
# Part 4: Consistency checking - all nondeleted interpreters should be
# there:
test interp-5.1 {testing consistency} {
interp children
} ""
test interp-5.2 {testing consistency} {
interp exists a
} 0
test interp-5.3 {testing consistency} {
interp exists nonexistent
} 0
# Recreate interpreter "a"
interp create a
# Part 5: Testing eval in interpreter object command and with interp command
test interp-6.1 {testing eval} {
a eval expr {{3 + 5}}
} 8
test interp-6.2 {testing eval} -returnCodes error -body {
a eval foo
} -result {invalid command name "foo"}
test interp-6.3 {testing eval} {
a eval {proc foo {} {expr {3 + 5}}}
a eval foo
} 8
catch {a eval {proc foo {} {expr {3 + 5}}}}
test interp-6.4 {testing eval} {
interp eval a foo
} 8
test interp-6.5 {testing eval} {
interp create {a x2}
interp eval {a x2} {proc frob {} {expr {4 * 9}}}
interp eval {a x2} frob
} 36
catch {interp create {a x2}}
test interp-6.6 {testing eval} -returnCodes error -body {
interp eval {a x2} foo
} -result {invalid command name "foo"}
# UTILITY PROCEDURE RUNNING IN PARENT INTERPRETER:
proc in_parent {args} {
return [list seen in parent: $args]
}
# Part 6: Testing basic alias creation
test interp-7.1 {testing basic alias creation} {
a alias foo in_parent
} foo
catch {a alias foo in_parent}
test interp-7.2 {testing basic alias creation} {
a alias bar in_parent a1 a2 a3
} bar
catch {a alias bar in_parent a1 a2 a3}
# Test 6.3 has been deleted.
test interp-7.3 {testing basic alias creation} {
a alias foo
} in_parent
test interp-7.4 {testing basic alias creation} {
a alias bar
} {in_parent a1 a2 a3}
test interp-7.5 {testing basic alias creation} {
lsort [a aliases]
} {bar foo}
test interp-7.6 {testing basic aliases arg checking} -returnCodes error -body {
a aliases too many args
} -result {wrong # args: should be "a aliases"}
# Part 7: testing basic alias invocation
test interp-8.1 {testing basic alias invocation} {
catch {interp create a}
a alias foo in_parent
a eval foo s1 s2 s3
} {seen in parent: {s1 s2 s3}}
test interp-8.2 {testing basic alias invocation} {
catch {interp create a}
a alias bar in_parent a1 a2 a3
a eval bar s1 s2 s3
} {seen in parent: {a1 a2 a3 s1 s2 s3}}
test interp-8.3 {testing basic alias invocation} -returnCodes error -body {
catch {interp create a}
a alias
} -result {wrong # args: should be "a alias aliasName ?targetName? ?arg ...?"}
# Part 8: Testing aliases for non-existent or hidden targets
test interp-9.1 {testing aliases for non-existent targets} {
catch {interp create a}
a alias zop nonexistent-command-in-parent
list [catch {a eval zop} msg] $msg
} {1 {invalid command name "nonexistent-command-in-parent"}}
test interp-9.2 {testing aliases for non-existent targets} {
catch {interp create a}
a alias zop nonexistent-command-in-parent
proc nonexistent-command-in-parent {} {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-parent] != ""} {
rename nonexistent-command-in-parent {}
}
# 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_parent b1 b2 b3
a eval a_command m1 m2 m3
} {seen in parent: {b1 b2 b3 a1 a2 a3 m1 m2 m3}}
test interp-10.7 {testing aliases between interpreters} {
catch {interp delete a}
interp create a
interp alias "" foo a zoppo
a eval {proc zoppo {x} {list $x $x $x}}
set x [foo 33]
a eval {rename zoppo {}}
interp alias "" foo a {}
return $x
} {33 33 33}
# Part 10: Testing "interp target"
test interp-11.1 {testing interp target} {
list [catch {interp target} msg] $msg
} {1 {wrong # args: should be "interp target path alias"}}
test interp-11.2 {testing interp target} {
list [catch {interp target nosuchinterpreter foo} msg] $msg
} {1 {could not find interpreter "nosuchinterpreter"}}
test interp-11.3 {testing interp target} {
catch {interp delete a}
interp create a
a alias boo no_command
interp target a boo
} ""
test interp-11.4 {testing interp target} {
catch {interp delete x1}
interp create x1
x1 eval interp create x2
x1 eval x2 eval interp create x3
catch {interp delete y1}
interp create y1
y1 eval interp create y2
y1 eval y2 eval interp create y3
interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand
interp target {x1 x2 x3} xcommand
} {y1 y2 y3}
test interp-11.5 {testing interp target} {
catch {interp delete x1}
interp create x1
interp create {x1 x2}
interp create {x1 x2 x3}
catch {interp delete y1}
interp create y1
interp create {y1 y2}
interp create {y1 y2 y3}
interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand
list [catch {x1 eval {interp target {x2 x3} xcommand}} msg] $msg
} {1 {target interpreter for alias "xcommand" in path "x2 x3" is not my descendant}}
test interp-11.6 {testing interp target} {
foreach a [interp aliases] {
rename $a {}
}
list [catch {interp target {} foo} msg] $msg
} {1 {alias "foo" in path "" not found}}
test interp-11.7 {testing interp target} {
catch {interp delete a}
interp create a
list [catch {interp target a foo} msg] $msg
} {1 {alias "foo" in path "a" not found}}
# Part 11: testing "interp issafe"
test interp-12.1 {testing interp issafe} {
interp issafe
} 0
test interp-12.2 {testing interp issafe} {
catch {interp delete a}
interp create a
interp issafe a
} 0
test interp-12.3 {testing interp issafe} {
catch {interp delete a}
interp create a
interp create {a x3} -safe
interp issafe {a x3}
} 1
test interp-12.4 {testing interp issafe} {
catch {interp delete a}
interp create a
interp create {a x3} -safe
interp create {a x3 foo}
interp issafe {a x3 foo}
} 1
# Part 12: testing interpreter object command "issafe" sub-command
test interp-13.1 {testing foo issafe} {
catch {interp delete a}
interp create a
a issafe
} 0
test interp-13.2 {testing foo issafe} {
catch {interp delete a}
interp create a
interp create {a x3} -safe
a eval x3 issafe
} 1
test interp-13.3 {testing foo issafe} {
catch {interp delete a}
interp create a
interp create {a x3} -safe
interp create {a x3 foo}
a eval x3 eval foo issafe
} 1
test interp-13.4 {testing issafe arg checking} {
catch {interp create a}
list [catch {a issafe too many args} msg] $msg
} {1 {wrong # args: should be "a issafe"}}
# part 14: testing interp aliases
test interp-14.1 {testing interp aliases} -setup {
interp create abc
} -body {
interp eval abc {interp aliases}
} -cleanup {
interp delete abc
} -result ""
test interp-14.2 {testing interp aliases} {
catch {interp delete a}
interp create a
a alias a1 puts
a alias a2 puts
a alias a3 puts
lsort [interp aliases a]
} {a1 a2 a3}
test interp-14.3 {testing interp aliases} {
catch {interp delete a}
interp create a
interp create {a x3}
interp alias {a x3} froboz "" puts
interp aliases {a x3}
} froboz
test interp-14.4 {testing interp alias - alias over parent} {
# SF Bug 641195
catch {interp delete a}
interp create a
list [catch {interp alias "" a a eval} msg] $msg [info commands a]
} {1 {cannot define or rename alias "a": interpreter deleted} {}}
test interp-14.5 {testing interp-alias: wrong # args} -body {
proc setx x {set x}
interp alias {} a {} setx
catch {a 1 2}
set ::errorInfo
} -cleanup {
rename setx {}
rename a {}
} -result {wrong # args: should be "a x"
while executing
"a 1 2"}
test interp-14.6 {testing interp-alias: wrong # args} -setup {
proc setx x {set x}
catch {interp delete a}
interp create a
} -body {
interp alias a a {} setx
catch {a eval a 1 2}
set ::errorInfo
} -cleanup {
rename setx {}
interp delete a
} -result {wrong # args: should be "a x"
invoked from within
"a 1 2"
invoked from within
"a eval a 1 2"}
test interp-14.7 {testing interp-alias: wrong # args} -setup {
proc setx x {set x}
catch {interp delete a}
interp create a
} -body {
interp alias a a {} setx
a eval {
catch {a 1 2}
set ::errorInfo
}
} -cleanup {
rename setx {}
interp delete a
} -result {wrong # args: should be "a x"
invoked from within
"a 1 2"}
test interp-14.8 {testing interp-alias: error messages} -body {
proc setx x {return -code error x}
interp alias {} a {} setx
catch {a 1}
set ::errorInfo
} -cleanup {
rename setx {}
rename a {}
} -result {x
while executing
"a 1"}
test interp-14.9 {testing interp-alias: error messages} -setup {
proc setx x {return -code error x}
catch {interp delete a}
interp create a
} -body {
interp alias a a {} setx
catch {a eval a 1}
set ::errorInfo
} -cleanup {
rename setx {}
interp delete a
} -result {x
invoked from within
"a 1"
invoked from within
"a eval a 1"}
test interp-14.10 {testing interp-alias: error messages} -setup {
proc setx x {return -code error x}
catch {interp delete a}
interp create a
} -body {
interp alias a a {} setx
a eval {
catch {a 1}
set ::errorInfo
}
} -cleanup {
rename setx {}
interp delete a
} -result {x
invoked from within
"a 1"}
test interp-14.11 {{interp alias} {target named the empty string} {bug 2bf56185}} -setup {
set interp [interp create [info cmdcount]]
interp eval $interp {
proc {} args {return $args}
}
} -body {
interp alias {} p1 $interp {}
p1 one two three
} -cleanup {
interp delete $interp
} -result {one two three}
# part 15: testing file sharing
test interp-15.1 {testing file sharing} {
catch {interp delete z}
interp create z
z eval close stdout
list [catch {z eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}
test interp-15.2 {testing file sharing} -body {
catch {interp delete z}
interp create z
set f [open [makeFile {} file-15.2] w]
interp share "" $f z
z eval puts $f hello
z eval close $f
close $f
} -cleanup {
removeFile file-15.2
} -result ""
test interp-15.3 {testing file sharing} {
catch {interp delete xsafe}
interp create xsafe -safe
list [catch {xsafe eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}
test interp-15.4 {testing file sharing} -body {
catch {interp delete xsafe}
interp create xsafe -safe
set f [open [makeFile {} file-15.4] w]
interp share "" $f xsafe
xsafe eval puts $f hello
xsafe eval close $f
close $f
} -cleanup {
removeFile file-15.4
} -result ""
test interp-15.5 {testing file sharing} {
catch {interp delete xsafe}
interp create xsafe -safe
interp share "" stdout xsafe
list [catch {xsafe eval gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test interp-15.6 {testing file sharing} -body {
catch {interp delete xsafe}
interp create xsafe -safe
set f [open [makeFile {} file-15.6] w]
interp share "" $f xsafe
set x [list [catch [list xsafe eval gets $f] msg] $msg]
xsafe eval close $f
close $f
string compare [string tolower $x] \
[list 1 [format "channel \"%s\" wasn't opened for reading" $f]]
} -cleanup {
removeFile file-15.6
} -result 0
test interp-15.7 {testing file transferring} -body {
catch {interp delete xsafe}
interp create xsafe -safe
set f [open [makeFile {} file-15.7] w]
interp transfer "" $f xsafe
xsafe eval puts $f hello
xsafe eval close $f
} -cleanup {
removeFile file-15.7
} -result ""
test interp-15.8 {testing file transferring} -body {
catch {interp delete xsafe}
interp create xsafe -safe
set f [open [makeFile {} file-15.8] w]
interp transfer "" $f xsafe
xsafe eval close $f
set x [list [catch {close $f} msg] $msg]
string compare [string tolower $x] \
[list 1 [format "can not find channel named \"%s\"" $f]]
} -cleanup {
removeFile file-15.8
} -result 0
#
# Torture tests for interpreter deletion order
#
proc kill {} {interp delete xxx}
test interp-16.0 {testing deletion order} {
catch {interp delete xxx}
interp create xxx
xxx alias kill kill
list [catch {xxx eval kill} msg] $msg
} {0 {}}
test interp-16.1 {testing deletion order} {
catch {interp delete xxx}
interp create xxx
interp create {xxx yyy}
interp alias {xxx yyy} kill "" kill
list [catch {interp eval {xxx yyy} kill} msg] $msg
} {0 {}}
test interp-16.2 {testing deletion order} {
catch {interp delete xxx}
interp create xxx
interp create {xxx yyy}
interp alias {xxx yyy} kill "" kill
list [catch {xxx eval yyy eval kill} msg] $msg
} {0 {}}
test interp-16.3 {testing deletion order} {
catch {interp delete xxx}
interp create xxx
interp create ddd
xxx alias kill kill
interp alias ddd kill xxx kill
set x [ddd eval kill]
interp delete ddd
set x
} ""
test interp-16.4 {testing deletion order} {
catch {interp delete xxx}
interp create xxx
interp create {xxx yyy}
interp alias {xxx yyy} kill "" kill
interp create ddd
interp alias ddd kill {xxx yyy} kill
set x [ddd eval kill]
interp delete ddd
set x
} ""
test interp-16.5 {testing deletion order, bgerror} {
catch {interp delete xxx}
interp create xxx
xxx eval {proc bgerror {args} {exit}}
xxx alias exit kill xxx
proc kill {i} {interp delete $i}
xxx eval after 100 expr {a + b}
after 200
update
interp exists xxx
} 0
#
# Alias loop prevention testing.
#
test interp-17.1 {alias loop prevention} {
list [catch {interp alias {} a {} a} msg] $msg
} {1 {cannot define or rename alias "a": would create a loop}}
test interp-17.2 {alias loop prevention} {
catch {interp delete x}
interp create x
x alias a loop
list [catch {interp alias {} loop x a} msg] $msg
} {1 {cannot define or rename alias "loop": would create a loop}}
test interp-17.3 {alias loop prevention} {
catch {interp delete x}
interp create x
interp alias x a x b
list [catch {interp alias x b x a} msg] $msg
} {1 {cannot define or rename alias "b": would create a loop}}
test interp-17.4 {alias loop prevention} {
catch {interp delete x}
interp create x
interp alias x b x a
list [catch {x eval rename b a} msg] $msg
} {1 {cannot define or rename alias "a": would create a loop}}
test interp-17.5 {alias loop prevention} {
catch {interp delete x}
interp create x
x alias z l1
interp alias {} l2 x z
list [catch {rename l2 l1} msg] $msg
} {1 {cannot define or rename alias "l1": would create a loop}}
test interp-17.6 {alias loop prevention} {
catch {interp delete x}
interp create x
interp alias x a x b
x eval rename a c
list [catch {x eval rename c b} msg] $msg
} {1 {cannot define or rename alias "b": would create a loop}}
#
# Test robustness of Tcl_DeleteInterp when applied to a child interpreter.
# If there are bugs in the implementation these tests are likely to expose
# the bugs as a core dump.
#
test interp-18.1 {testing Tcl_DeleteInterp vs children} testinterpdelete {
list [catch {testinterpdelete} msg] $msg
} {1 {wrong # args: should be "testinterpdelete path"}}
test interp-18.2 {testing Tcl_DeleteInterp vs children} testinterpdelete {
catch {interp delete a}
interp create a
testinterpdelete a
} ""
test interp-18.3 {testing Tcl_DeleteInterp vs children} testinterpdelete {
catch {interp delete a}
interp create a
interp create {a b}
testinterpdelete {a b}
} ""
test interp-18.4 {testing Tcl_DeleteInterp vs children} testinterpdelete {
catch {interp delete a}
interp create a
interp create {a b}
testinterpdelete a
} ""
test interp-18.5 {testing Tcl_DeleteInterp vs children} testinterpdelete {
catch {interp delete a}
interp create a
interp create {a b}
interp alias {a b} dodel {} dodel
proc dodel {x} {testinterpdelete $x}
list [catch {interp eval {a b} {dodel {a b}}} msg] $msg
} {0 {}}
test interp-18.6 {testing Tcl_DeleteInterp vs children} testinterpdelete {
catch {interp delete a}
interp create a
interp create {a b}
interp alias {a b} dodel {} dodel
proc dodel {x} {testinterpdelete $x}
list [catch {interp eval {a b} {dodel a}} msg] $msg
} {0 {}}
test interp-18.7 {eval in deleted interp} {
catch {interp delete a}
interp create a
a eval {
proc dodel {} {
delme
dosomething else
}
proc dosomething args {
puts "I should not have been called!!"
}
}
a alias delme dela
proc dela {} {interp delete a}
list [catch {a eval dodel} msg] $msg
} {1 {attempt to call eval in deleted interpreter}}
test interp-18.8 {eval in deleted interp} {
catch {interp delete a}
interp create a
a eval {
interp create b
b eval {
proc dodel {} {
dela
}
}
proc foo {} {
b eval dela
dosomething else
}
proc dosomething args {
puts "I should not have been called!!"
}
}
interp alias {a b} dela {} dela
proc dela {} {interp delete a}
list [catch {a eval foo} msg] $msg
} {1 {attempt to call eval in deleted interpreter}}
test interp-18.9 {eval in deleted interp, bug 495830} {
interp create tst
interp alias tst suicide {} interp delete tst
list [catch {tst eval {suicide; set a 5}} msg] $msg
} {1 {attempt to call eval in deleted interpreter}}
test interp-18.10 {eval in deleted interp, bug 495830} {
interp create tst
interp alias tst suicide {} interp delete tst
list [catch {tst eval {set set set; suicide; $set a 5}} msg] $msg
} {1 {attempt to call eval in deleted interpreter}}
# Test alias deletion
test interp-19.1 {alias deletion} {
catch {interp delete a}
interp create a
interp alias a foo a bar
set s [interp alias a foo {}]
interp delete a
set s
} {}
test interp-19.2 {alias deletion} {
catch {interp delete a}
interp create a
catch {interp alias a foo {}} msg
interp delete a
set msg
} {alias "foo" not found}
test interp-19.3 {alias deletion} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a {rename foo zop}
interp alias a foo a zop
catch {interp eval a foo} msg
interp delete a
set msg
} {invalid command name "bar"}
test interp-19.4 {alias deletion} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a {rename foo zop}
catch {interp eval a foo} msg
interp delete a
set msg
} {invalid command name "foo"}
test interp-19.5 {alias deletion} {
catch {interp delete a}
interp create a
interp eval a {proc bar {} {return 1}}
interp alias a foo a bar
interp eval a {rename foo zop}
catch {interp eval a zop} msg
interp delete a
set msg
} 1
test interp-19.6 {alias deletion} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a {rename foo zop}
interp alias a foo a zop
set s [interp aliases a]
interp delete a
set s
} {::foo foo}
test interp-19.7 {alias deletion, renaming} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a rename foo blotz
interp alias a foo {}
set s [interp aliases a]
interp delete a
set s
} {}
test interp-19.8 {alias deletion, renaming} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a rename foo blotz
set l ""
lappend l [interp aliases a]
interp alias a foo {}
lappend l [interp aliases a]
interp delete a
set l
} {foo {}}
test interp-19.9 {alias deletion, renaming} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a rename foo blotz
interp eval a {proc foo {} {expr {34 * 34}}}
interp alias a foo {}
set l [interp eval a foo]
interp delete a
set l
} 1156
test interp-20.1 {interp hide, interp expose and interp invokehidden} {
set a [interp create]
$a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
$a eval {proc foo {} {}}
$a hide foo
catch {$a eval foo something} msg
interp delete $a
set msg
} {invalid command name "foo"}
test interp-20.2 {interp hide, interp expose and interp invokehidden} {
set a [interp create]
$a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
$a hide list
set l ""
lappend l [catch {$a eval {list 1 2 3}} msg] $msg
$a expose list
lappend l [catch {$a eval {list 1 2 3}} msg] $msg
interp delete $a
set l
} {1 {invalid command name "list"} 0 {1 2 3}}
test interp-20.3 {interp hide, interp expose and interp invokehidden} {
set a [interp create]
$a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
$a hide list
set l ""
lappend l [catch { $a eval {list 1 2 3} } msg] $msg
lappend l [catch { $a invokehidden list 1 2 3 } msg] $msg
$a expose list
lappend l [catch { $a eval {list 1 2 3} } msg] $msg
interp delete $a
set l
} {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}}
test interp-20.4 {interp hide, interp expose and interp invokehidden -- passing {}} {
set a [interp create]
$a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
$a hide list
set l ""
lappend l [catch { $a eval {list 1 2 3} } msg] $msg
lappend l [catch { $a invokehidden list {"" 1 2 3} } msg] $msg
$a expose list
lappend l [catch { $a eval {list 1 2 3} } msg] $msg
interp delete $a
set l
} {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}}
test interp-20.5 {interp hide, interp expose and interp invokehidden -- passing {}} {
set a [interp create]
$a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
$a hide list
set l ""
lappend l [catch { $a eval {list 1 2 3} } msg] $msg
lappend l [catch { $a invokehidden list {{} 1 2 3} } msg] $msg
$a expose list
lappend l [catch { $a eval {list 1 2 3} } msg] $msg
interp delete $a
set l
} {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}}
test interp-20.6 {interp invokehidden -- eval args} {
set a [interp create]
$a hide list
set l ""
set z 45
lappend l [catch { $a invokehidden list $z 1 2 3 } msg] $msg
$a expose list
lappend l [catch { $a eval list $z 1 2 3 } msg] $msg
interp delete $a
set l
} {0 {45 1 2 3} 0 {45 1 2 3}}
test interp-20.7 {interp invokehidden vs variable eval} {
set a [interp create]
$a hide list
set z 45
set l [list [catch {$a invokehidden list {$z a b c}} msg] $msg]
interp delete $a
set l
} {0 {{$z a b c}}}
test interp-20.8 {interp invokehidden vs variable eval} {
set a [interp create]
$a hide list
$a eval set z 89
set z 45
set l [list [catch {$a invokehidden list {$z a b c}} msg] $msg]
interp delete $a
set l
} {0 {{$z a b c}}}
test interp-20.9 {interp invokehidden vs variable eval} {
set a [interp create]
$a hide list
$a eval set z 89
set z 45
set l ""
lappend l [catch {$a invokehidden list $z {$z a b c}} msg] $msg
interp delete $a
set l
} {0 {45 {$z a b c}}}
test interp-20.10 {interp hide, interp expose and interp invokehidden} {
set a [interp create]
$a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
$a eval {proc foo {} {}}
interp hide $a foo
catch {interp eval $a foo something} msg
interp delete $a
set msg
} {invalid command name "foo"}
test interp-20.11 {interp hide, interp expose and interp invokehidden} {
set a [interp create]
$a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
interp hide $a list
set l ""
lappend l [catch {interp eval $a {list 1 2 3}} msg] $msg
interp expose $a list
lappend l [catch {interp eval $a {list 1 2 3}} msg] $msg
interp delete $a
set l
} {1 {invalid command name "list"} 0 {1 2 3}}
test interp-20.12 {interp hide, interp expose and interp invokehidden} {
set a [interp create]
$a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
interp hide $a list
set l ""
lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg
lappend l [catch {interp invokehidden $a list 1 2 3} msg] $msg
interp expose $a list
lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg
interp delete $a
set l
} {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}}
test interp-20.13 {interp hide, interp expose, interp invokehidden -- passing {}} {
set a [interp create]
$a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
interp hide $a list
set l ""
lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg
lappend l [catch {interp invokehidden $a list {"" 1 2 3}} msg] $msg
interp expose $a list
lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg
interp delete $a
set l
} {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}}
test interp-20.14 {interp hide, interp expose, interp invokehidden -- passing {}} {
set a [interp create]
$a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
interp hide $a list
set l ""
lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg
lappend l [catch {interp invokehidden $a list {{} 1 2 3}} msg] $msg
interp expose $a list
lappend l [catch {$a eval {list 1 2 3} } msg] $msg
interp delete $a
set l
} {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}}
test interp-20.15 {interp invokehidden -- eval args} {
catch {interp delete a}
interp create a
interp hide a list
set l ""
set z 45
lappend l [catch {interp invokehidden a list $z 1 2 3} msg]
lappend l $msg
a expose list
lappend l [catch {interp eval a list $z 1 2 3} msg]
lappend l $msg
interp delete a
set l
} {0 {45 1 2 3} 0 {45 1 2 3}}
test interp-20.16 {interp invokehidden vs variable eval} {
catch {interp delete a}
interp create a
interp hide a list
set z 45
set l ""
lappend l [catch {interp invokehidden a list {$z a b c}} msg]
lappend l $msg
interp delete a
set l
} {0 {{$z a b c}}}
test interp-20.17 {interp invokehidden vs variable eval} {
catch {interp delete a}
interp create a
interp hide a list
a eval set z 89
set z 45
set l ""
lappend l [catch {interp invokehidden a list {$z a b c}} msg]
lappend l $msg
interp delete a
set l
} {0 {{$z a b c}}}
test interp-20.18 {interp invokehidden vs variable eval} {
catch {interp delete a}
interp create a
interp hide a list
a eval set z 89
set z 45
set l ""
lappend l [catch {interp invokehidden a list $z {$z a b c}} msg]
lappend l $msg
interp delete a
set l
} {0 {45 {$z a b c}}}
test interp-20.19 {interp invokehidden vs nested commands} {
catch {interp delete a}
interp create a
a hide list
set l [a invokehidden list {[list x y z] f g h} z]
interp delete a
set l
} {{[list x y z] f g h} z}
test interp-20.20 {interp invokehidden vs nested commands} {
catch {interp delete a}
interp create a
a hide list
set l [interp invokehidden a list {[list x y z] f g h} z]
interp delete a
set l
} {{[list x y z] f g h} z}
test interp-20.21 {interp hide vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {a hide list} msg]
lappend l $msg
interp delete a
set l
} {0 {}}
test interp-20.22 {interp hide vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {interp hide a list} msg]
lappend l $msg
interp delete a
set l
} {0 {}}
test interp-20.23 {interp hide vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {a eval {interp hide {} list}} msg]
lappend l $msg
interp delete a
set l
} {1 {permission denied: safe interpreter cannot hide commands}}
test interp-20.24 {interp hide vs safety} {
catch {interp delete a}
interp create a -safe
interp create {a b}
set l ""
lappend l [catch {a eval {interp hide b list}} msg]
lappend l $msg
interp delete a
set l
} {1 {permission denied: safe interpreter cannot hide commands}}
test interp-20.25 {interp hide vs safety} {
catch {interp delete a}
interp create a -safe
interp create {a b}
set l ""
lappend l [catch {interp hide {a b} list} msg]
lappend l $msg
interp delete a
set l
} {0 {}}
test interp-20.26 {interp expoose vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {a hide list} msg]
lappend l $msg
lappend l [catch {a expose list} msg]
lappend l $msg
interp delete a
set l
} {0 {} 0 {}}
test interp-20.27 {interp expose vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {interp hide a list} msg]
lappend l $msg
lappend l [catch {interp expose a list} msg]
lappend l $msg
interp delete a
set l
} {0 {} 0 {}}
test interp-20.28 {interp expose vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {a hide list} msg]
lappend l $msg
lappend l [catch {a eval {interp expose {} list}} msg]
lappend l $msg
interp delete a
set l
} {0 {} 1 {permission denied: safe interpreter cannot expose commands}}
test interp-20.29 {interp expose vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [catch {interp hide a list} msg]
lappend l $msg
lappend l [catch {a eval {interp expose {} list}} msg]
lappend l $msg
interp delete a
set l
} {0 {} 1 {permission denied: safe interpreter cannot expose commands}}
test interp-20.30 {interp expose vs safety} {
catch {interp delete a}
interp create a -safe
interp create {a b}
set l ""
lappend l [catch {interp hide {a b} list} msg]
lappend l $msg
lappend l [catch {a eval {interp expose b list}} msg]
lappend l $msg
interp delete a
set l
} {0 {} 1 {permission denied: safe interpreter cannot expose commands}}
test interp-20.31 {interp expose vs safety} {
catch {interp delete a}
interp create a -safe
interp create {a b}
set l ""
lappend l [catch {interp hide {a b} list} msg]
lappend l $msg
lappend l [catch {interp expose {a b} list} msg]
lappend l $msg
interp delete a
set l
} {0 {} 0 {}}
test interp-20.32 {interp invokehidden vs safety} {
catch {interp delete a}
interp create a -safe
interp hide a list
set l ""
lappend l [catch {a eval {interp invokehidden {} list a b c}} msg]
lappend l $msg
interp delete a
set l
} {1 {not allowed to invoke hidden commands from safe interpreter}}
test interp-20.33 {interp invokehidden vs safety} {
catch {interp delete a}
interp create a -safe
interp hide a list
set l ""
lappend l [catch {a eval {interp invokehidden {} list a b c}} msg]
lappend l $msg
lappend l [catch {a invokehidden list a b c} msg]
lappend l $msg
interp delete a
set l
} {1 {not allowed to invoke hidden commands from safe interpreter}\
0 {a b c}}
test interp-20.34 {interp invokehidden vs safety} {
catch {interp delete a}
interp create a -safe
interp create {a b}
interp hide {a b} list
set l ""
lappend l [catch {a eval {interp invokehidden b list a b c}} msg]
lappend l $msg
lappend l [catch {interp invokehidden {a b} list a b c} msg]
lappend l $msg
interp delete a
set l
} {1 {not allowed to invoke hidden commands from safe interpreter}\
0 {a b c}}
test interp-20.35 {invokehidden at local level} {
catch {interp delete a}
interp create a
a eval {
proc p1 {} {
set z 90
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a h1
}
set r [interp eval a p1]
interp delete a
set r
} 91
test interp-20.36 {invokehidden at local level} {
catch {interp delete a}
interp create a
a eval {
set z 90
proc p1 {} {
global z
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a h1
}
set r [interp eval a p1]
interp delete a
set r
} 91
test interp-20.37 {invokehidden at local level} {
catch {interp delete a}
interp create a
a eval {
proc p1 {} {
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a h1
}
set r [interp eval a p1]
interp delete a
set r
} 91
test interp-20.38 {invokehidden at global level} {
catch {interp delete a}
interp create a
a eval {
proc p1 {} {
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a -global h1
}
set r [catch {interp eval a p1} msg]
interp delete a
list $r $msg
} {1 {can't read "z": no such variable}}
test interp-20.39 {invokehidden at global level} {
catch {interp delete a}
interp create a
a eval {
proc p1 {} {
global z
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a -global h1
}
set r [catch {interp eval a p1} msg]
interp delete a
list $r $msg
} {0 91}
test interp-20.40 {safe, invokehidden at local level} {
catch {interp delete a}
interp create a -safe
a eval {
proc p1 {} {
set z 90
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a h1
}
set r [interp eval a p1]
interp delete a
set r
} 91
test interp-20.41 {safe, invokehidden at local level} {
catch {interp delete a}
interp create a -safe
a eval {
set z 90
proc p1 {} {
global z
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a h1
}
set r [interp eval a p1]
interp delete a
set r
} 91
test interp-20.42 {safe, invokehidden at local level} {
catch {interp delete a}
interp create a -safe
a eval {
proc p1 {} {
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a h1
}
set r [interp eval a p1]
interp delete a
set r
} 91
test interp-20.43 {invokehidden at global level} {
catch {interp delete a}
interp create a
a eval {
proc p1 {} {
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a -global h1
}
set r [catch {interp eval a p1} msg]
interp delete a
list $r $msg
} {1 {can't read "z": no such variable}}
test interp-20.44 {invokehidden at global level} {
catch {interp delete a}
interp create a
a eval {
proc p1 {} {
global z
a1
set z
}
proc h1 {} {
upvar z z
set z 91
}
}
a hide h1
a alias a1 a1
proc a1 {} {
interp invokehidden a -global h1
}
set r [catch {interp eval a p1} msg]
interp delete a
list $r $msg
} {0 91}
test interp-20.45 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
namespace eval foo {}
proc foo::x {} {}
}
set l [list [catch {interp hide a foo::x} msg] $msg]
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.46 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
namespace eval foo {}
proc foo::x {} {}
}
set l [list [catch {interp hide a foo::x x} msg] $msg]
interp delete a
set l
} {1 {can only hide global namespace commands (use rename then hide)}}
test interp-20.47 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
proc x {} {}
}
set l [list [catch {interp hide a x foo::x} msg] $msg]
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.48 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
namespace eval foo {}
proc foo::x {} {}
}
set l [list [catch {interp hide a foo::x bar::x} msg] $msg]
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.49 {interp invokehidden -namespace} -setup {
set script [makeFile {
set x [namespace current]
} script]
interp create -safe child
} -body {
child invokehidden -namespace ::foo source $script
child eval {set ::foo::x}
} -cleanup {
interp delete child
removeFile script
} -result ::foo
test interp-20.50 {Bug 2486550} -setup {
interp create child
} -body {
child hide coroutine
child invokehidden coroutine
} -cleanup {
interp delete child
} -returnCodes error -match glob -result *
test interp-20.50.1 {Bug 2486550} -setup {
interp create child
} -body {
child hide coroutine
catch {child invokehidden coroutine} m o
dict get $o -errorinfo
} -cleanup {
unset -nocomplain m 0
interp delete child
} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?"
while executing
"coroutine"
invoked from within
"child invokehidden coroutine"}
test interp-21.1 {interp hidden} {
interp hidden {}
} ""
test interp-21.2 {interp hidden} {
interp hidden
} ""
test interp-21.3 {interp hidden vs interp hide, interp expose} -setup {
set l ""
} -body {
lappend l [interp hidden]
interp hide {} pwd
lappend l [interp hidden]
interp expose {} pwd
lappend l [interp hidden]
} -result {{} pwd {}}
test interp-21.4 {interp hidden} -setup {
catch {interp delete a}
} -body {
interp create a
interp hidden a
} -cleanup {
interp delete a
} -result ""
test interp-21.5 {interp hidden} -setup {
catch {interp delete a}
} -body {
interp create -safe a
lsort [interp hidden a]
} -cleanup {
interp delete a
} -result $hidden_cmds
test interp-21.6 {interp hidden vs interp hide, interp expose} -setup {
catch {interp delete a}
set l ""
} -body {
interp create a
lappend l [interp hidden a]
interp hide a pwd
lappend l [interp hidden a]
interp expose a pwd
lappend l [interp hidden a]
} -cleanup {
interp delete a
} -result {{} pwd {}}
test interp-21.7 {interp hidden} -setup {
catch {interp delete a}
} -body {
interp create a
a hidden
} -cleanup {
interp delete a
} -result ""
test interp-21.8 {interp hidden} -setup {
catch {interp delete a}
} -body {
interp create a -safe
lsort [a hidden]
} -cleanup {
interp delete a
} -result $hidden_cmds
test interp-21.9 {interp hidden vs interp hide, interp expose} -setup {
catch {interp delete a}
set l ""
} -body {
interp create a
lappend l [a hidden]
a hide pwd
lappend l [a hidden]
a expose pwd
lappend l [a hidden]
} -cleanup {
interp delete a
} -result {{} pwd {}}
test interp-22.1 {testing interp marktrusted} {
catch {interp delete a}
interp create a
set l ""
lappend l [a issafe]
lappend l [a marktrusted]
lappend l [a issafe]
interp delete a
set l
} {0 {} 0}
test interp-22.2 {testing interp marktrusted} {
catch {interp delete a}
interp create a
set l ""
lappend l [interp issafe a]
lappend l [interp marktrusted a]
lappend l [interp issafe a]
interp delete a
set l
} {0 {} 0}
test interp-22.3 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [a issafe]
lappend l [a marktrusted]
lappend l [a issafe]
interp delete a
set l
} {1 {} 0}
test interp-22.4 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [interp issafe a]
lappend l [interp marktrusted a]
lappend l [interp issafe a]
interp delete a
set l
} {1 {} 0}
test interp-22.5 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
interp create {a b}
catch {a eval {interp marktrusted b}} msg
interp delete a
set msg
} {permission denied: safe interpreter cannot mark trusted}
test interp-22.6 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
interp create {a b}
catch {a eval {b marktrusted}} msg
interp delete a
set msg
} {permission denied: safe interpreter cannot mark trusted}
test interp-22.7 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [interp issafe a]
interp marktrusted a
interp create {a b}
lappend l [interp issafe a]
lappend l [interp issafe {a b}]
interp delete a
set l
} {1 0 0}
test interp-22.8 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [interp issafe a]
interp create {a b}
lappend l [interp issafe {a b}]
interp marktrusted a
interp create {a c}
lappend l [interp issafe a]
lappend l [interp issafe {a c}]
interp delete a
set l
} {1 1 0 0}
test interp-22.9 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
set l ""
lappend l [interp issafe a]
interp create {a b}
lappend l [interp issafe {a b}]
interp marktrusted {a b}
lappend l [interp issafe a]
lappend l [interp issafe {a b}]
interp create {a b c}
lappend l [interp issafe {a b c}]
interp delete a
set l
} {1 1 1 0 0}
test interp-23.1 {testing hiding vs aliases: unsafe interp} -setup {
catch {interp delete a}
set l ""
} -body {
interp create a
lappend l [interp hidden a]
a alias bar bar
lappend l [interp aliases a] [interp hidden a]
a hide bar
lappend l [interp aliases a] [interp hidden a]
a alias bar {}
lappend l [interp aliases a] [interp hidden a]
} -cleanup {
interp delete a
} -result {{} bar {} bar bar {} {}}
test interp-23.2 {testing hiding vs aliases: safe interp} -setup {
catch {interp delete a}
set l ""
} -constraints {unixOrWin} -body {
interp create a -safe
lappend l [lsort [interp hidden a]]
a alias bar bar
lappend l [lsort [interp aliases a]] [lsort [interp hidden a]]
a hide bar
lappend l [lsort [interp aliases a]] [lsort [interp hidden a]]
a alias bar {}
lappend l [lsort [interp aliases a]] [lsort [interp hidden a]]
} -cleanup {
interp delete a
} -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds]
test interp-24.1 {result resetting on error} -setup {
catch {interp delete a}
} -body {
interp create a
interp alias a foo {} apply {args {error $args}}
interp eval a {
lappend l [catch {foo 1 2 3} msg] $msg
lappend l [catch {foo 3 4 5} msg] $msg
}
} -cleanup {
interp delete a
} -result {1 {1 2 3} 1 {3 4 5}}
test interp-24.2 {result resetting on error} -setup {
catch {interp delete a}
} -body {
interp create a -safe
interp alias a foo {} apply {args {error $args}}
interp eval a {
lappend l [catch {foo 1 2 3} msg] $msg
lappend l [catch {foo 3 4 5} msg] $msg
}
} -cleanup {
interp delete a
} -result {1 {1 2 3} 1 {3 4 5}}
test interp-24.3 {result resetting on error} -setup {
catch {interp delete a}
} -body {
interp create a
interp create {a b}
interp eval a {
proc foo args {error $args}
}
interp alias {a b} foo a foo
interp eval {a b} {
lappend l [catch {foo 1 2 3} msg] $msg
lappend l [catch {foo 3 4 5} msg] $msg
}
} -cleanup {
interp delete a
} -result {1 {1 2 3} 1 {3 4 5}}
test interp-24.4 {result resetting on error} -setup {
catch {interp delete a}
} -body {
interp create a -safe
interp create {a b}
interp eval a {
proc foo args {error $args}
}
interp alias {a b} foo a foo
interp eval {a b} {
lappend l [catch {foo 1 2 3} msg]
lappend l $msg
lappend l [catch {foo 3 4 5} msg]
lappend l $msg
}
} -cleanup {
interp delete a
} -result {1 {1 2 3} 1 {3 4 5}}
test interp-24.5 {result resetting on error} -setup {
catch {interp delete a}
catch {interp delete b}
} -body {
interp create a
interp create b
interp eval a {
proc foo args {error $args}
}
interp alias b foo a foo
interp eval b {
lappend l [catch {foo 1 2 3} msg] $msg
lappend l [catch {foo 3 4 5} msg] $msg
}
} -cleanup {
interp delete a
interp delete b
} -result {1 {1 2 3} 1 {3 4 5}}
test interp-24.6 {result resetting on error} -setup {
catch {interp delete a}
catch {interp delete b}
} -body {
interp create a -safe
interp create b -safe
interp eval a {
proc foo args {error $args}
}
interp alias b foo a foo
interp eval b {
lappend l [catch {foo 1 2 3} msg] $msg
lappend l [catch {foo 3 4 5} msg] $msg
}
} -cleanup {
interp delete a
interp delete b
} -result {1 {1 2 3} 1 {3 4 5}}
test interp-24.7 {result resetting on error} -setup {
catch {interp delete a}
set l {}
} -body {
interp create a
interp eval a {
proc foo args {error $args}
}
lappend l [catch {interp eval a foo 1 2 3} msg] $msg
lappend l [catch {interp eval a foo 3 4 5} msg] $msg
} -cleanup {
interp delete a
} -result {1 {1 2 3} 1 {3 4 5}}
test interp-24.8 {result resetting on error} -setup {
catch {interp delete a}
set l {}
} -body {
interp create a -safe
interp eval a {
proc foo args {error $args}
}
lappend l [catch {interp eval a foo 1 2 3} msg] $msg
lappend l [catch {interp eval a foo 3 4 5} msg] $msg
} -cleanup {
interp delete a
} -result {1 {1 2 3} 1 {3 4 5}}
test interp-24.9 {result resetting on error} -setup {
catch {interp delete a}
set l {}
} -body {
interp create a
interp create {a b}
interp eval {a b} {
proc foo args {error $args}
}
interp eval a {
proc foo args {
eval interp eval b foo $args
}
}
lappend l [catch {interp eval a foo 1 2 3} msg] $msg
lappend l [catch {interp eval a foo 3 4 5} msg] $msg
} -cleanup {
interp delete a
} -result {1 {1 2 3} 1 {3 4 5}}
test interp-24.10 {result resetting on error} -setup {
catch {interp delete a}
set l {}
} -body {
interp create a -safe
interp create {a b}
interp eval {a b} {
proc foo args {error $args}
}
interp eval a {
proc foo args {
eval interp eval b foo $args
}
}
lappend l [catch {interp eval a foo 1 2 3} msg] $msg
lappend l [catch {interp eval a foo 3 4 5} msg] $msg
} -cleanup {
interp delete a
} -result {1 {1 2 3} 1 {3 4 5}}
test interp-24.11 {result resetting on error} -setup {
catch {interp delete a}
} -body {
interp create a
interp create {a b}
interp eval {a b} {
proc foo args {error $args}
}
interp eval a {
proc foo args {
lappend l [catch {eval interp eval b foo $args} msg] $msg
lappend l [catch {eval interp eval b foo $args} msg] $msg
}
}
interp eval a foo 1 2 3
} -cleanup {
interp delete a
} -result {1 {1 2 3} 1 {1 2 3}}
test interp-24.12 {result resetting on error} -setup {
catch {interp delete a}
} -body {
interp create a -safe
interp create {a b}
interp eval {a b} {
proc foo args {error $args}
}
interp eval a {
proc foo args {
lappend l [catch {eval interp eval b foo $args} msg] $msg
lappend l [catch {eval interp eval b foo $args} msg] $msg
}
}
interp eval a foo 1 2 3
} -cleanup {
interp delete a
} -result {1 {1 2 3} 1 {1 2 3}}
test interp-25.1 {testing aliasing of string commands} -setup {
catch {interp delete a}
} -body {
interp create a
a alias exec foo ;# Relies on exec being a string command!
interp delete a
} -result ""
#
# Interps result transmission
#
test interp-26.1 {result code transmission : interp eval direct} {
# Test that all the possibles error codes from Tcl get passed up
# from the child interp's context to the parent, even though the
# child 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
# child interp's context to the parent, even though the child nominally
# thinks the command is running at the root level.
catch {interp delete a}
interp create a
set res {}
proc MyTestAlias {code} {
return -code $code ret$code
}
interp alias a Test {} MyTestAlias
for {set code -1} {$code<=5} {incr code} {
lappend res [interp eval a [list catch [list Test $code] msg]]
}
interp delete a
set res
} {-1 0 1 2 3 4 5}
test interp-26.4 {result code transmission: invoke hidden direct--bug 1637} \
{knownBug} {
# The known bug is that code 2 is returned, not the -code argument
catch {interp delete a}
interp create a
set res {}
interp hide a return
for {set code -1} {$code<=5} {incr code} {
lappend res [catch {interp invokehidden a return -code $code ret$code}]
}
interp delete a
set res
} {-1 0 1 2 3 4 5}
test interp-26.5 {result code transmission: invoke hidden indirect--bug 1637} -setup {
catch {interp delete a}
interp create a
} -body {
# The known bug is that the break and continue should raise errors that
# they are used outside a loop.
set res {}
interp eval a {proc retcode {code} {return -code $code ret$code}}
interp hide a retcode
for {set code -1} {$code<=5} {incr code} {
lappend res [catch {interp invokehidden a retcode $code} msg] $msg
}
return $res
} -cleanup {
interp delete a
} -result {-1 ret-1 0 ret0 1 ret1 2 ret2 3 ret3 4 ret4 5 ret5}
test interp-26.6 {result code transmission: all combined--bug 1637} -setup {
set interp [interp create]
} -constraints knownBug -body {
# Test that all the possibles error codes from Tcl get passed in both
# directions. This doesn't work.
proc MyTestAlias {interp args} {
global aliasTrace
lappend aliasTrace $args
interp invokehidden $interp {*}$args
}
foreach c {return} {
interp hide $interp $c
interp alias $interp $c {} MyTestAlias $interp $c
}
interp eval $interp {proc ret {code} {return -code $code ret$code}}
set res {}
set aliasTrace {}
for {set code -1} {$code<=5} {incr code} {
lappend res [catch {interp eval $interp ret $code} msg] $msg
}
return $res
} -cleanup {
interp delete $interp
} -result {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}
# Some tests might need to be added to check for difference between toplevel
# and non-toplevel evals.
# End of return code transmission section
test interp-26.7 {errorInfo transmission: regular interps} -setup {
set interp [interp create]
} -body {
proc MyError {secret} {
return -code error "msg"
}
proc MyTestAlias {interp args} {
MyError "some secret"
}
interp alias $interp test {} MyTestAlias $interp
interp eval $interp {catch test;set ::errorInfo}
} -cleanup {
interp delete $interp
} -result {msg
while executing
"MyError "some secret""
(procedure "MyTestAlias" line 2)
invoked from within
"test"}
test interp-26.8 {errorInfo transmission: safe interps--bug 1637} -setup {
set interp [interp create -safe]
} -constraints knownBug -body {
# this test fails because the errorInfo is fully transmitted whether the
# interp is safe or not. The errorInfo should never report data from the
# parent interpreter because it could contain sensitive information.
proc MyError {secret} {
return -code error "msg"
}
proc MyTestAlias {interp args} {
MyError "some secret"
}
interp alias $interp test {} MyTestAlias $interp
interp eval $interp {catch test;set ::errorInfo}
} -cleanup {
interp delete $interp
} -result {msg
while executing
"test"}
# Interps & Namespaces
test interp-27.1 {interp aliases & namespaces} -setup {
set i [interp create]
} -body {
set aliasTrace {}
proc tstAlias {args} {
global aliasTrace
lappend aliasTrace [list [namespace current] $args]
}
$i alias foo::bar tstAlias foo::bar
$i eval foo::bar test
return $aliasTrace
} -cleanup {
interp delete $i
} -result {{:: {foo::bar test}}}
test interp-27.2 {interp aliases & namespaces} -setup {
set i [interp create]
} -body {
set aliasTrace {}
proc tstAlias {args} {
global aliasTrace
lappend aliasTrace [list [namespace current] $args]
}
$i alias foo::bar tstAlias foo::bar
$i eval namespace eval foo {bar test}
return $aliasTrace
} -cleanup {
interp delete $i
} -result {{:: {foo::bar test}}}
test interp-27.3 {interp aliases & namespaces} -setup {
set i [interp create]
} -body {
set aliasTrace {}
proc tstAlias {args} {
global aliasTrace
lappend aliasTrace [list [namespace current] $args]
}
interp eval $i {namespace eval foo {proc bar {} {error "bar called"}}}
interp alias $i foo::bar {} tstAlias foo::bar
interp eval $i {namespace eval foo {bar test}}
return $aliasTrace
} -cleanup {
interp delete $i
} -result {{:: {foo::bar test}}}
test interp-27.4 {interp aliases & namespaces} -setup {
set i [interp create]
} -body {
namespace eval foo2 {
variable aliasTrace {}
proc bar {args} {
variable aliasTrace
lappend aliasTrace [list [namespace current] $args]
}
}
$i alias foo::bar foo2::bar foo::bar
$i eval namespace eval foo {bar test}
return $foo2::aliasTrace
} -cleanup {
namespace delete foo2
interp delete $i
} -result {{::foo2 {foo::bar test}}}
test interp-27.5 {interp hidden & namespaces} -setup {
set i [interp create]
} -constraints knownBug -body {
interp eval $i {
namespace eval foo {
proc bar {args} {
return "bar called ([namespace current]) ($args)"
}
}
}
set res [list [interp eval $i {namespace eval foo {bar test1}}]]
interp hide $i foo::bar
lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg]
} -cleanup {
interp delete $i
} -result {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}}
test interp-27.6 {interp hidden & aliases & namespaces} -setup {
set i [interp create]
} -constraints knownBug -body {
set v root-parent
namespace eval foo {
variable v foo-parent
proc bar {interp args} {
variable v
list "parent bar called ($v) ([namespace current]) ($args)"\
[interp invokehidden $interp foo::bar $args]
}
}
interp eval $i {
namespace eval foo {
namespace export *
variable v foo-child
proc bar {args} {
variable v
return "child 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-child
namespace eval test {
variable v foo-test
namespace import ::foo::*
bar test2
}
}]]
} -cleanup {
namespace delete foo
interp delete $i
} -result {{child bar called (foo-child) (::foo) (test1)} {parent bar called (foo-parent) (::foo) (test2)} {child bar called (foo-child) (::foo) (test2)}}
test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup {
set i [interp create]
} -constraints knownBug -body {
set v root-parent
namespace eval mfoo {
variable v foo-parent
proc bar {interp args} {
variable v
list "parent bar called ($v) ([namespace current]) ($args)"\
[interp invokehidden $interp test::bar $args]
}
}
interp eval $i {
namespace eval foo {
namespace export *
variable v foo-child
proc bar {args} {
variable v
return "child bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)"
}
}
set v root-child
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 {{child bar called (foo-child) (bar test1) (::tcltest) (::foo) (test1)} {parent bar called (foo-parent) (::mfoo) (test2)} {child bar called (foo-child) (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 child's namespace ?} -setup {
set i [interp create -safe]
proc parent {interp args} {interp hide $interp list}
} -body {
$i alias parent parent $i
set r [interp eval $i {
namespace eval foo {
proc list {args} {
return "dummy foo::list"
}
parent
}
info commands list
}]
} -cleanup {
rename parent {}
interp delete $i
} -result {}
test interp-28.2 {parent's nsName cache should not cross} -setup {
set i [interp create]
$i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}}
} -body {
$i eval {
set x {namespace children ::}
set y [list namespace children ::]
namespace delete {*}[filter [{*}$y]]
set j [interp create]
$j alias filter filter
$j eval {namespace delete {*}[filter [namespace children ::]]}
namespace eval foo {}
list [filter [eval $x]] [filter [eval $y]] [filter [$j eval $x]] [filter [$j eval $y]]
}
} -cleanup {
interp delete $i
} -result {::foo ::foo {} {}}
# Part 29: recursion limit
# 29.1.* Argument checking
# 29.2.* Reading and setting the recursion limit
# 29.3.* Does the recursion limit work?
# 29.4.* Recursion limit inheritance by sub-interpreters
# 29.5.* Confirming the recursionlimit command does not affect the parent
# 29.6.* Safe interpreter restriction
test interp-29.1.1 {interp recursionlimit argument checking} {
list [catch {interp recursionlimit} msg] $msg
} {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}}
test interp-29.1.2 {interp recursionlimit argument checking} {
list [catch {interp recursionlimit foo bar} msg] $msg
} {1 {could not find interpreter "foo"}}
test interp-29.1.3 {interp recursionlimit argument checking} {
list [catch {interp recursionlimit foo bar baz} msg] $msg
} {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}}
test interp-29.1.4 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo bar} msg]
interp delete moo
list $result $msg
} {1 {expected integer but got "bar"}}
test interp-29.1.5 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo 0} msg]
interp delete moo
list $result $msg
} {1 {recursion limit must be > 0}}
test interp-29.1.6 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo -1} msg]
interp delete moo
list $result $msg
} {1 {recursion limit must be > 0}}
test interp-29.1.7 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg]
interp delete moo
list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.1.8 {child 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 {child 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 {child 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 {child 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 {child recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg]
interp delete moo
list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.2.1 {query recursion limit} {
interp recursionlimit {}
} 1000
test interp-29.2.2 {query recursion limit} {
set i [interp create]
set n [interp recursionlimit $i]
interp delete $i
set n
} 1000
test interp-29.2.3 {query recursion limit} {
set i [interp create]
set n [$i recursionlimit]
interp delete $i
set n
} 1000
test interp-29.2.4 {query recursion limit} {
set i [interp create]
set r [$i eval {
set n1 [interp recursionlimit {} 42]
set n2 [interp recursionlimit {}]
list $n1 $n2
}]
interp delete $i
set r
} {42 42}
test interp-29.2.5 {query recursion limit} {
set i [interp create]
set n1 [interp recursionlimit $i 42]
set n2 [interp recursionlimit $i]
interp delete $i
list $n1 $n2
} {42 42}
test interp-29.2.6 {query recursion limit} {
set i [interp create]
set n1 [interp recursionlimit $i 42]
set n2 [$i recursionlimit]
interp delete $i
list $n1 $n2
} {42 42}
test interp-29.2.7 {query recursion limit} {
set i [interp create]
set n1 [$i recursionlimit 42]
set n2 [interp recursionlimit $i]
interp delete $i
list $n1 $n2
} {42 42}
test interp-29.2.8 {query recursion limit} {
set i [interp create]
set n1 [$i recursionlimit 42]
set n2 [$i recursionlimit]
interp delete $i
list $n1 $n2
} {42 42}
test interp-29.3.1 {recursion limit} {
set i [interp create]
set r [interp eval $i {
interp recursionlimit {} 50
proc p {} {incr ::i; p}
set i 0
list [catch p msg] $msg $i
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 49}
test interp-29.3.2 {recursion limit} {
set i [interp create]
interp recursionlimit $i 50
set r [interp eval $i {
proc p {} {incr ::i; p}
set i 0
list [catch p msg] $msg $i
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 49}
test interp-29.3.3 {recursion limit} {
set i [interp create]
$i recursionlimit 50
set r [interp eval $i {
proc p {} {incr ::i; p}
set i 0
list [catch p msg] $msg $i
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 49}
test interp-29.3.4 {recursion limit error reporting} {
interp create child
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
interp recursionlimit {} 5
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {1 {falling back due to new recursion limit}}
test interp-29.3.5 {recursion limit error reporting} {
interp create child
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
interp recursionlimit {} 4
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {1 {falling back due to new recursion limit}}
test interp-29.3.6 {recursion limit error reporting} {
interp create child
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
interp recursionlimit {} 6
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
#
# Note that TEBC does not verify the interp's nesting level itself; the nesting
# level will only be verified when it invokes a non-bcc'd command.
#
test interp-29.3.7a {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.7b {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
update
eval { # 5
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.7c {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set set set
$set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.8a {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 4}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.8b {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 4}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
update
eval { # 5
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.9a {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 6}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.9b {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 6}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
set set set
$set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.10a {recursion limit error reporting} {
interp create child
after 0 {child recursionlimit 4}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.10b {recursion limit error reporting} {
interp create child
after 0 {child recursionlimit 4}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
update
eval { # 5
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.11a {recursion limit error reporting} {
interp create child
after 0 {child recursionlimit 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.11b {recursion limit error reporting} {
interp create child
after 0 {child recursionlimit 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set set set
$set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.12a {recursion limit error reporting} {
interp create child
after 0 {child recursionlimit 6}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.3.12b {recursion limit error reporting} {
interp create child
after 0 {child recursionlimit 6}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set set set
$set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.4.1 {recursion limit inheritance} {
set i [interp create]
set ii [interp eval $i {
interp recursionlimit {} 50
interp create
}]
set r [interp eval [list $i $ii] {
proc p {} {incr ::i; p}
set i 0
catch p
set i
}]
interp delete $i
set r
} 50
test interp-29.4.2 {recursion limit inheritance} {
set i [interp create]
$i recursionlimit 50
set ii [interp eval $i {interp create}]
set r [interp eval [list $i $ii] {
proc p {} {incr ::i; p}
set i 0
catch p
set i
}]
interp delete $i
set r
} 50
test interp-29.5.1 {does child recursion limit affect parent?} {
set before [interp recursionlimit {}]
set i [interp create]
interp recursionlimit $i 20000
set after [interp recursionlimit {}]
set childlimit [interp recursionlimit $i]
interp delete $i
list [expr {$before == $after}] $childlimit
} {1 20000}
test interp-29.5.2 {does child recursion limit affect parent?} {
set before [interp recursionlimit {}]
set i [interp create]
interp recursionlimit $i 20000
set after [interp recursionlimit {}]
set childlimit [$i recursionlimit]
interp delete $i
list [expr {$before == $after}] $childlimit
} {1 20000}
test interp-29.5.3 {does child recursion limit affect parent?} {
set before [interp recursionlimit {}]
set i [interp create]
$i recursionlimit 20000
set after [interp recursionlimit {}]
set childlimit [interp recursionlimit $i]
interp delete $i
list [expr {$before == $after}] $childlimit
} {1 20000}
test interp-29.5.4 {does child recursion limit affect parent?} {
set before [interp recursionlimit {}]
set i [interp create]
$i recursionlimit 20000
set after [interp recursionlimit {}]
set childlimit [$i recursionlimit]
interp delete $i
list [expr {$before == $after}] $childlimit
} {1 20000}
test interp-29.6.1 {safe interpreter recursion limit} {
interp create child -safe
set n [interp recursionlimit child]
interp delete child
set n
} 1000
test interp-29.6.2 {safe interpreter recursion limit} {
interp create child -safe
set n [child recursionlimit]
interp delete child
set n
} 1000
test interp-29.6.3 {safe interpreter recursion limit} {
interp create child -safe
set n1 [interp recursionlimit child 42]
set n2 [interp recursionlimit child]
interp delete child
list $n1 $n2
} {42 42}
test interp-29.6.4 {safe interpreter recursion limit} {
interp create child -safe
set n1 [child recursionlimit 42]
set n2 [interp recursionlimit child]
interp delete child
list $n1 $n2
} {42 42}
test interp-29.6.5 {safe interpreter recursion limit} {
interp create child -safe
set n1 [interp recursionlimit child 42]
set n2 [child recursionlimit]
interp delete child
list $n1 $n2
} {42 42}
test interp-29.6.6 {safe interpreter recursion limit} {
interp create child -safe
set n1 [child recursionlimit 42]
set n2 [child recursionlimit]
interp delete child
list $n1 $n2
} {42 42}
test interp-29.6.7 {safe interpreter recursion limit} {
interp create child -safe
set n1 [child recursionlimit 42]
set n2 [child recursionlimit]
interp delete child
list $n1 $n2
} {42 42}
test interp-29.6.8 {safe interpreter recursion limit} {
interp create child -safe
set n [catch {child eval {interp recursionlimit {} 42}} msg]
interp delete child
list $n $msg
} {1 {permission denied: safe interpreters cannot change recursion limit}}
test interp-29.6.9 {safe interpreter recursion limit} {
interp create child -safe
set result [
child eval {
interp create child2 -safe
set n [catch {
interp recursionlimit child2 42
} msg]
list $n $msg
}
]
interp delete child
set result
} {1 {permission denied: safe interpreters cannot change recursion limit}}
test interp-29.6.10 {safe interpreter recursion limit} {
interp create child -safe
set result [
child eval {
interp create child2 -safe
set n [catch {
child2 recursionlimit 42
} msg]
list $n $msg
}
]
interp delete child
set result
} {1 {permission denied: safe interpreters cannot change recursion limit}}
# # Deep recursion (into interps when the regular one fails):
# # still crashes...
# proc p {} {
# if {[catch p ret]} {
# catch {
# set i [interp create]
# interp eval $i [list proc p {} [info body p]]
# interp eval $i p
# }
# interp delete $i
# return ok
# }
# return $ret
# }
# p
# more tests needed...
# Interp & stack
#test interp-29.1 {interp and stack (info level)} {
#} {}
# End of stack-recursion tests
# This test dumps core in Tcl 8.0.3!
test interp-30.1 {deletion of aliases inside namespaces} {
set i [interp create]
$i alias ns::cmd list
$i alias ns::cmd {}
} {}
test interp-31.1 {alias invocation scope} {
proc mySet {varName value} {
upvar 1 $varName localVar
set localVar $value
}
interp alias {} myNewSet {} mySet
proc testMyNewSet {value} {
myNewSet a $value
return $a
}
unset -nocomplain a
set result [testMyNewSet "ok"]
rename testMyNewSet {}
rename mySet {}
rename myNewSet {}
set result
} ok
test interp-32.1 {parent's working directory should be inherited by a child interp} -setup {
cd [temporaryDirectory]
} -body {
set parent [pwd]
set i [interp create]
set child [$i eval pwd]
interp delete $i
file mkdir cwd_test
cd cwd_test
lappend parent [pwd]
set i [interp create]
lappend child [$i eval pwd]
cd ..
file delete cwd_test
interp delete $i
expr {[string equal $parent $child] ? 1 :
"\{$parent\} != \{$child\}"}
} -cleanup {
cd [workingDirectory]
} -result 1
test interp-33.1 {refCounting for target words of alias [Bug 730244]} {
# This test will panic if Bug 730244 is not fixed.
set i [interp create]
proc testHelper args {rename testHelper {}; return $args}
# Note: interp names are simple words by default
trace add execution testHelper enter "interp alias $i alias {} ;#"
interp alias $i alias {} testHelper this
$i eval alias
} this
test interp-34.1 {basic test of limits - calling commands} -body {
set i [interp create]
$i eval {
proc foobar {} {
for {set x 0} {$x<1000000} {incr x} {
# Calls to this are not bytecoded away
pid
}
}
}
$i limit command -value 1000
$i eval foobar
} -returnCodes error -result {command count limit exceeded} -cleanup {
interp delete $i
}
test interp-34.2 {basic test of limits - bytecoded commands} -body {
set i [interp create]
$i eval {
proc foobar {} {
for {set x 0} {$x<1000000} {incr x} {
# Calls to this *are* bytecoded away
expr {1+2+3}
}
}
}
$i limit command -value 1000
$i eval foobar
} -returnCodes error -result {command count limit exceeded} -cleanup {
interp delete $i
}
test interp-34.3 {basic test of limits - pure bytecode loop} -body {
set i [interp create]
$i eval {
proc foobar {} {
while {1} {
# No bytecode at all here...
}
}
}
# We use a time limit here; command limits don't trap this case
$i limit time -seconds [expr {[clock seconds]+2}]
$i eval foobar
} -returnCodes error -result {time limit exceeded} -cleanup {
interp delete $i
}
test interp-34.3.1 {basic test of limits - pure inside-command loop} -body {
set i [interp create]
$i eval {
proc foobar {} {
set while while
$while {1} {
# No bytecode at all here...
}
}
}
# We use a time limit here; command limits don't trap this case
$i limit time -seconds [expr {[clock seconds] + 2}]
$i eval foobar
} -returnCodes error -result {time limit exceeded} -cleanup {
interp delete $i
}
test interp-34.4 {limits with callbacks: extending limits} -setup {
set i [interp create]
set a 0
set b 0
set c a
proc cb1 {} {
global c
incr ::$c
}
proc cb2 {newlimit args} {
global c i
set c b
$i limit command -value $newlimit
}
} -body {
interp alias $i foo {} cb1
set curlim [$i eval info cmdcount]
$i limit command -command "cb2 [expr {$curlim + 100}]" \
-value [expr {$curlim + 10}]
$i eval {for {set i 0} {$i<10} {incr i} {foo}}
list $a $b $c
} -result {6 4 b} -cleanup {
interp delete $i
rename cb1 {}
rename cb2 {}
}
# The next three tests exercise all the three ways that limit handlers
# can be deleted. Fully verifying this requires additional source
# code instrumentation.
test interp-34.5 {limits with callbacks: removing limits} -setup {
set i [interp create]
set a 0
set b 0
set c a
proc cb1 {} {
global c
incr ::$c
}
proc cb2 {newlimit args} {
global c i
set c b
$i limit command -value $newlimit
}
} -body {
interp alias $i foo {} cb1
set curlim [$i eval info cmdcount]
$i limit command -command "cb2 {}" -value [expr {$curlim + 10}]
$i eval {for {set i 0} {$i<10} {incr i} {foo}}
list $a $b $c
} -result {6 4 b} -cleanup {
interp delete $i
rename cb1 {}
rename cb2 {}
}
test interp-34.6 {limits with callbacks: removing limits and handlers} -setup {
set i [interp create]
set a 0
set b 0
set c a
proc cb1 {} {
global c
incr ::$c
}
proc cb2 {args} {
global c i
set c b
$i limit command -value {} -command {}
}
} -body {
interp alias $i foo {} cb1
set curlim [$i eval info cmdcount]
$i limit command -command cb2 -value [expr {$curlim + 10}]
$i eval {for {set i 0} {$i<10} {incr i} {foo}}
list $a $b $c
} -result {6 4 b} -cleanup {
interp delete $i
rename cb1 {}
rename cb2 {}
}
test interp-34.7 {limits with callbacks: deleting the handler interp} -setup {
set i [interp create]
$i eval {
set i [interp create]
proc cb1 {} {
global c
incr ::$c
}
proc cb2 {args} {
global c i curlim
set c b
$i limit command -value [expr {$curlim + 1000}]
trapToParent
}
}
proc cb3 {} {
global i subi
interp alias [list $i $subi] foo {} cb4
interp delete $i
}
proc cb4 {} {
global n
incr n
}
} -body {
set subi [$i eval set i]
interp alias $i trapToParent {} cb3
set n 0
$i eval {
set a 0
set b 0
set c a
interp alias $i foo {} cb1
set curlim [$i eval info cmdcount]
$i limit command -command cb2 -value [expr {$curlim + 10}]
}
$i eval {
$i eval {
for {set i 0} {$i<10} {incr i} {foo}
}
}
list $n [interp exists $i]
} -result {4 0} -cleanup {
rename cb3 {}
rename cb4 {}
}
# Bug 1085023
test interp-34.8 {time limits trigger in vwaits} -body {
set i [interp create]
interp limit $i time -seconds [expr {[clock seconds] + 1}] -granularity 1
$i eval {
set x {}
vwait x
}
} -cleanup {
interp delete $i
} -returnCodes error -result {limit exceeded}
test interp-34.9 {time limits trigger in blocking after} {
set i [interp create]
set t0 [clock seconds]
interp limit $i time -seconds [expr {$t0 + 1}] -granularity 1
set code [catch {
$i eval {after 10000}
} msg]
set t1 [clock seconds]
interp delete $i
list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}]
} {1 {time limit exceeded} OK}
test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body {
set i [interp create]
# Assume someone hasn't set the clock to early 1970!
$i limit time -seconds 1 -granularity 4
interp alias $i log {} lappend result
set result {}
catch {
$i eval {
log 1
after 100
log 2
}
} msg
interp delete $i
lappend result $msg
} -result {1 {time limit exceeded}}
test interp-34.11 {time limit extension in callbacks} -setup {
proc cb1 {i t} {
global result
lappend result cb1
$i limit time -seconds $t -command cb2
}
proc cb2 {} {
global result
lappend result cb2
}
} -body {
set i [interp create]
set t0 [clock seconds]
$i limit time -seconds [expr {$t0 + 1}] -granularity 1 \
-command "cb1 $i [expr {$t0 + 2}]"
set ::result {}
lappend ::result [catch {
$i eval {
for {set i 0} {$i<30} {incr i} {
after 100
}
}
} msg] $msg
set t1 [clock seconds]
lappend ::result [expr {$t1-$t0>=2 ? "ok" : "$t0,$t1"}]
interp delete $i
return $::result
} -result {cb1 cb2 1 {time limit exceeded} ok} -cleanup {
rename cb1 {}
rename cb2 {}
}
test interp-34.12 {time limit extension in callbacks} -setup {
proc cb1 {i} {
global result times
lappend result cb1
set times [lassign $times t]
$i limit time -seconds $t
}
} -body {
set i [interp create]
set t0 [clock seconds]
set ::times "[expr {$t0 + 2}] [expr {$t0 + 100}]"
$i limit time -seconds [expr {$t0 + 1}] -granularity 1 -command "cb1 $i"
set ::result {}
lappend ::result [catch {
$i eval {
for {set i 0} {$i<30} {incr i} {
after 100
}
}
} msg] $msg
set t1 [clock seconds]
lappend ::result [expr {$t1-$t0>=2 ? "ok" : "$t0,$t1"}]
interp delete $i
return $::result
} -result {cb1 cb1 0 {} ok} -cleanup {
rename cb1 {}
}
test interp-34.13 {time limit granularity and vwait: Bug 2891362} -setup {
set i [interp create -safe]
} -body {
$i limit time -seconds [clock add [clock seconds] 1 second]
$i eval {
after 2000 set x timeout
vwait x
return $x
}
} -cleanup {
interp delete $i
} -returnCodes error -result {limit exceeded}
test interp-35.1 {interp limit syntax} -body {
interp limit
} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"}
test interp-35.2 {interp limit syntax} -body {
interp limit {}
} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"}
test interp-35.3 {interp limit syntax} -body {
interp limit {} foo
} -returnCodes error -result {bad limit type "foo": must be commands or time}
test interp-35.4 {interp limit syntax} -body {
set i [interp create]
set dict [interp limit $i commands]
set result {}
foreach key [lsort [dict keys $dict]] {
lappend result $key [dict get $dict $key]
}
set result
} -cleanup {
interp delete $i
} -result {-command {} -granularity 1 -value {}}
test interp-35.5 {interp limit syntax} -body {
set i [interp create]
interp limit $i commands -granularity
} -cleanup {
interp delete $i
} -result 1
test interp-35.6 {interp limit syntax} -body {
set i [interp create]
interp limit $i commands -granularity 2
} -cleanup {
interp delete $i
} -result {}
test interp-35.7 {interp limit syntax} -body {
set i [interp create]
interp limit $i commands -foobar
} -cleanup {
interp delete $i
} -returnCodes error -result {bad option "-foobar": must be -command, -granularity, or -value}
test interp-35.8 {interp limit syntax} -body {
set i [interp create]
interp limit $i commands -granularity foobar
} -cleanup {
interp delete $i
} -returnCodes error -result {expected integer but got "foobar"}
test interp-35.9 {interp limit syntax} -body {
set i [interp create]
interp limit $i commands -granularity 0
} -cleanup {
interp delete $i
} -returnCodes error -result {granularity must be at least 1}
test interp-35.10 {interp limit syntax} -body {
set i [interp create]
interp limit $i commands -value foobar
} -cleanup {
interp delete $i
} -returnCodes error -result {expected integer but got "foobar"}
test interp-35.11 {interp limit syntax} -body {
set i [interp create]
interp limit $i commands -value -1
} -cleanup {
interp delete $i
} -returnCodes error -result {command limit value must be at least 0}
test interp-35.12 {interp limit syntax} -body {
set i [interp create]
set dict [interp limit $i time]
set result {}
foreach key [lsort [dict keys $dict]] {
lappend result $key [dict get $dict $key]
}
set result
} -cleanup {
interp delete $i
} -result {-command {} -granularity 10 -milliseconds {} -seconds {}}
test interp-35.13 {interp limit syntax} -body {
set i [interp create]
interp limit $i time -granularity
} -cleanup {
interp delete $i
} -result 10
test interp-35.14 {interp limit syntax} -body {
set i [interp create]
interp limit $i time -granularity 2
} -cleanup {
interp delete $i
} -result {}
test interp-35.15 {interp limit syntax} -body {
set i [interp create]
interp limit $i time -foobar
} -cleanup {
interp delete $i
} -returnCodes error -result {bad option "-foobar": must be -command, -granularity, -milliseconds, or -seconds}
test interp-35.16 {interp limit syntax} -body {
set i [interp create]
interp limit $i time -granularity foobar
} -cleanup {
interp delete $i
} -returnCodes error -result {expected integer but got "foobar"}
test interp-35.17 {interp limit syntax} -body {
set i [interp create]
interp limit $i time -granularity 0
} -cleanup {
interp delete $i
} -returnCodes error -result {granularity must be at least 1}
test interp-35.18 {interp limit syntax} -body {
set i [interp create]
interp limit $i time -seconds foobar
} -cleanup {
interp delete $i
} -returnCodes error -result {expected integer but got "foobar"}
test interp-35.19 {interp limit syntax} -body {
set i [interp create]
interp limit $i time -seconds -1
} -cleanup {
interp delete $i
} -returnCodes error -result {seconds must be at least 0}
test interp-35.20 {interp limit syntax} -body {
set i [interp create]
interp limit $i time -millis foobar
} -cleanup {
interp delete $i
} -returnCodes error -result {expected integer but got "foobar"}
test interp-35.21 {interp limit syntax} -body {
set i [interp create]
interp limit $i time -millis -1
} -cleanup {
interp delete $i
} -returnCodes error -result {milliseconds must be at least 0}
test interp-35.22 {interp time limits normalize milliseconds} -body {
set i [interp create]
interp limit $i time -seconds 1 -millis 1500
list [$i limit time -seconds] [$i limit time -millis]
} -cleanup {
interp delete $i
} -result {2 500}
# Bug 3398794
test interp-35.23 {interp command limits can't touch current interp} -body {
interp limit {} commands -value 10
} -returnCodes error -result {limits on current interpreter inaccessible}
test interp-35.24 {interp time limits can't touch current interp} -body {
interp limit {} time -seconds 2
} -returnCodes error -result {limits on current interpreter inaccessible}
test interp-36.1 {interp bgerror syntax} -body {
interp bgerror
} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"}
test interp-36.2 {interp bgerror syntax} -body {
interp bgerror x y z
} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"}
test interp-36.3 {interp bgerror syntax} -setup {
interp create child
} -body {
child bgerror x y
} -cleanup {
interp delete child
} -returnCodes error -result {wrong # args: should be "child bgerror ?cmdPrefix?"}
test interp-36.4 {ChildBgerror syntax} -setup {
interp create child
} -body {
child bgerror \{
} -cleanup {
interp delete child
} -returnCodes error -result {cmdPrefix must be list of length >= 1}
test interp-36.5 {ChildBgerror syntax} -setup {
interp create child
} -body {
child bgerror {}
} -cleanup {
interp delete child
} -returnCodes error -result {cmdPrefix must be list of length >= 1}
test interp-36.6 {ChildBgerror returns handler} -setup {
interp create child
} -body {
child bgerror {foo bar soom}
} -cleanup {
interp delete child
} -result {foo bar soom}
test interp-36.7 {ChildBgerror sets error handler of child [1999035]} -setup {
interp create child
child alias handler handler
child bgerror handler
variable result {untouched}
proc handler {args} {
variable result
set result [lindex $args 0]
}
} -body {
child eval {
variable done {}
after 0 error foo
after 10 [list ::set [namespace which -variable done] {}]
vwait [namespace which -variable done]
}
set result
} -cleanup {
variable result {}
unset -nocomplain result
interp delete child
} -result foo
test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup {
catch {interp delete a}
interp create a
set result {}
} -body {
interp create {a b} -safe
lappend result [interp eval a {expr {min(5,2,3)*max(7,13,11)}}]
lappend result [interp eval {a b} {expr {min(5,2,3)*max(7,13,11)}}]
} -cleanup {
unset -nocomplain result
interp delete a
} -result {26 26}
test interp-38.1 {interp debug one-way switch} -setup {
catch {interp delete a}
interp create a
interp debug a -frame 1
} -body {
# TIP #3xx interp debug frame is a one-way switch
interp debug a -frame 0
} -cleanup {
interp delete a
} -result {1}
test interp-38.2 {interp debug env var} -setup {
catch {interp delete a}
set ::env(TCL_INTERP_DEBUG_FRAME) 1
interp create a
} -body {
interp debug a
} -cleanup {
unset -nocomplain ::env(TCL_INTERP_DEBUG_FRAME)
interp delete a
} -result {-frame 1}
test interp-38.3 {interp debug wrong args} -body {
interp debug
} -returnCodes {
error
} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
test interp-38.4 {interp debug basic setup} -constraints {!singleTestInterp} -body {
interp debug {}
} -result {-frame 0}
test interp-38.5 {interp debug basic setup} -constraints {!singleTestInterp} -body {
interp debug {} -f
} -result {0}
test interp-38.6 {interp debug basic setup} -body {
interp debug -frames
} -returnCodes error -result {could not find interpreter "-frames"}
test interp-38.7 {interp debug basic setup} -body {
interp debug {} -frames
} -returnCodes error -result {bad debug option "-frames": must be -frame}
test interp-38.8 {interp debug basic setup} -body {
interp debug {} -frame 0 bogus
} -returnCodes {
error
} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
# cleanup
unset -nocomplain hidden_cmds
foreach i [interp children] {
interp delete $i
}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
Reference in New Issue View Git Blame Copy Permalink