diff options
Diffstat (limited to 'tests/interp.test')
| -rw-r--r-- | tests/interp.test | 1175 |
1 files changed, 894 insertions, 281 deletions
diff --git a/tests/interp.test b/tests/interp.test index ff38301..510ab4a 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -15,27 +15,21 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } -# The set of hidden commands is platform dependent: +testConstraint testinterpdelete [llength [info commands testinterpdelete]] -if {"$tcl_platform(platform)" == "macintosh"} { - set hidden_cmds {beep cd echo encoding exit fconfigure file glob load ls open pwd socket source} -} else { - set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source} -} +set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source unload} foreach i [interp slaves] { interp delete $i } -proc equiv {x} {return $x} - # Part 0: Check out options for interp command test interp-1.1 {options for interp command} { list [catch {interp} msg] $msg } {1 {wrong # args: should be "interp cmd ?arg ...?"}} test interp-1.2 {options for interp command} { list [catch {interp frobox} msg] $msg -} {1 {bad option "frobox": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}} +} {1 {bad option "frobox": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} test interp-1.3 {options for interp command} { interp delete } "" @@ -53,13 +47,13 @@ test interp-1.6 {options for interp command} { } {1 {wrong # args: should be "interp slaves ?path?"}} test interp-1.7 {options for interp command} { list [catch {interp hello} msg] $msg -} {1 {bad option "hello": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}} +} {1 {bad option "hello": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} test interp-1.8 {options for interp command} { list [catch {interp -froboz} msg] $msg -} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}} +} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} test interp-1.9 {options for interp command} { list [catch {interp -froboz -safe} msg] $msg -} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}} +} {1 {bad option "-froboz": must be alias, aliases, bgerror, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} test interp-1.10 {options for interp command} { list [catch {interp target} msg] $msg } {1 {wrong # args: should be "interp target path alias"}} @@ -381,7 +375,7 @@ test interp-10.7 {testing aliases between interpreters} { set x [foo 33] a eval {rename zoppo {}} interp alias "" foo a {} - equiv $x + return $x } {33 33 33} # Part 10: Testing "interp target" @@ -437,74 +431,170 @@ test interp-11.7 {testing interp target} { test interp-12.1 {testing interp issafe} { interp issafe } 0 -test interp-12.2 {testing interp issafe} { +test interp-12.2 {testing interp issafe} -setup { catch {interp delete a} +} -body { interp create a interp issafe a -} 0 -test interp-12.3 {testing interp issafe} { +} -result 0 +test interp-12.3 {testing interp issafe} -setup { catch {interp delete a} +} -body { interp create a interp create {a x3} -safe interp issafe {a x3} -} 1 -test interp-12.4 {testing interp issafe} { +} -result 1 +test interp-12.4 {testing interp issafe} -setup { catch {interp delete a} +} -body { interp create a interp create {a x3} -safe interp create {a x3 foo} interp issafe {a x3 foo} -} 1 +} -result 1 # Part 12: testing interpreter object command "issafe" sub-command -test interp-13.1 {testing foo issafe} { +test interp-13.1 {testing foo issafe} -setup { catch {interp delete a} +} -body { interp create a a issafe -} 0 -test interp-13.2 {testing foo issafe} { +} -result 0 +test interp-13.2 {testing foo issafe} -setup { catch {interp delete a} +} -body { interp create a interp create {a x3} -safe a eval x3 issafe -} 1 -test interp-13.3 {testing foo issafe} { +} -result 1 +test interp-13.3 {testing foo issafe} -setup { catch {interp delete a} +} -body { 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} { +} -result 1 +test interp-13.4 {testing issafe arg checking} -body { catch {interp create a} - list [catch {a issafe too many args} msg] $msg -} {1 {wrong # args: should be "a issafe"}} + a issafe too many args +} -returnCodes error -result {wrong # args: should be "a issafe"} # part 14: testing interp aliases test interp-14.1 {testing interp aliases} { interp aliases } "" -test interp-14.2 {testing interp aliases} { +test interp-14.2 {testing interp aliases} -setup { catch {interp delete a} +} -body { 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} { +} -result {a1 a2 a3} +test interp-14.3 {testing interp aliases} -setup { catch {interp delete a} +} -body { interp create a interp create {a x3} interp alias {a x3} froboz "" puts interp aliases {a x3} -} froboz -test interp-14.4 {testing interp alias - alias over master} { - # SF Bug 641195 +} -result froboz +test interp-14.4 {testing interp alias - alias over master} -setup { catch {interp delete a} +} -body { + # SF Bug 641195 interp create a list [catch {interp alias "" a a eval} msg] $msg [info commands a] -} {1 {cannot define or rename alias "a": interpreter deleted} {}} +} -result {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"} + # part 15: testing file sharing test interp-15.1 {testing file sharing} { @@ -664,14 +754,21 @@ test interp-17.4 {alias loop prevention} { interp create x interp alias x b x a list [catch {x eval rename b a} msg] $msg -} {1 {cannot define or rename alias "b": would create a loop}} +} {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 "l2": would create a loop}} +} {1 {cannot define or rename alias "l1": would create a loop}} +test interp-17.6 {alias loop prevention} { + catch {interp delete x} + interp create x + interp alias x a x b + x eval rename a c + list [catch {x eval rename c b} msg] $msg +} {1 {cannot define or rename alias "b": would create a loop}} # # Test robustness of Tcl_DeleteInterp when applied to a slave interpreter. @@ -679,86 +776,81 @@ test interp-17.5 {alias loop prevention} { # the bugs as a core dump. # -if {[info commands testinterpdelete] == ""} { - puts "This application hasn't been compiled with the \"testinterpdelete\"" - puts "command, so I can't test slave delete calls" -} else { - test interp-18.1 {testing Tcl_DeleteInterp vs slaves} { - list [catch {testinterpdelete} msg] $msg - } {1 {wrong # args: should be "testinterpdelete path"}} - test interp-18.2 {testing Tcl_DeleteInterp vs slaves} { - catch {interp delete a} - interp create a - testinterpdelete a - } "" - test interp-18.3 {testing Tcl_DeleteInterp vs slaves} { - catch {interp delete a} - interp create a - interp create {a b} - testinterpdelete {a b} - } "" - test interp-18.4 {testing Tcl_DeleteInterp vs slaves} { - catch {interp delete a} - interp create a - interp create {a b} - testinterpdelete a - } "" - test interp-18.5 {testing Tcl_DeleteInterp vs slaves} { - catch {interp delete a} - interp create a - interp create {a b} - interp alias {a b} dodel {} dodel - proc dodel {x} {testinterpdelete $x} - list [catch {interp eval {a b} {dodel {a b}}} msg] $msg - } {0 {}} - test interp-18.6 {testing Tcl_DeleteInterp vs slaves} { - catch {interp delete a} - interp create a - interp create {a b} - interp alias {a b} dodel {} dodel - proc dodel {x} {testinterpdelete $x} - list [catch {interp eval {a b} {dodel a}} msg] $msg - } {0 {}} - test interp-18.7 {eval in deleted interp} { - catch {interp delete a} - interp create a - a eval { +test interp-18.1 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { + list [catch {testinterpdelete} msg] $msg +} {1 {wrong # args: should be "testinterpdelete path"}} +test interp-18.2 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { + catch {interp delete a} + interp create a + testinterpdelete a +} "" +test interp-18.3 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { + catch {interp delete a} + interp create a + interp create {a b} + testinterpdelete {a b} +} "" +test interp-18.4 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { + catch {interp delete a} + interp create a + interp create {a b} + testinterpdelete a +} "" +test interp-18.5 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { + catch {interp delete a} + interp create a + interp create {a b} + interp alias {a b} dodel {} dodel + proc dodel {x} {testinterpdelete $x} + list [catch {interp eval {a b} {dodel {a b}}} msg] $msg +} {0 {}} +test interp-18.6 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { + catch {interp delete a} + interp create a + interp create {a b} + interp alias {a b} dodel {} dodel + proc dodel {x} {testinterpdelete $x} + list [catch {interp eval {a b} {dodel a}} msg] $msg +} {0 {}} +test interp-18.7 {eval in deleted interp} { + catch {interp delete a} + interp create a + a eval { + proc dodel {} { + delme + dosomething else + } + proc dosomething args { + puts "I should not have been called!!" + } + } + a alias delme dela + proc dela {} {interp delete a} + list [catch {a eval dodel} msg] $msg +} {1 {attempt to call eval in deleted interpreter}} +test interp-18.8 {eval in deleted interp} { + catch {interp delete a} + interp create a + a eval { + interp create b + b eval { proc dodel {} { - delme - dosomething else - } - proc dosomething args { - puts "I should not have been called!!" + dela } } - 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!!" - } + proc foo {} { + b eval dela + dosomething else } - interp alias {a b} dela {} dela - proc dela {} {interp delete a} - list [catch {a eval foo} msg] $msg - } {1 {attempt to call eval in deleted interpreter}} -} -test interp-18.9 {eval in deleted interp, bug 495830} {knownBug} { + 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 @@ -795,7 +887,7 @@ test interp-19.3 {alias deletion} { catch {interp eval a foo} msg interp delete a set msg -} {invalid command name "zop"} +} {invalid command name "bar"} test interp-19.4 {alias deletion} { catch {interp delete a} interp create a @@ -824,7 +916,7 @@ test interp-19.6 {alias deletion} { set s [interp aliases a] interp delete a set s -} foo +} {::foo foo} test interp-19.7 {alias deletion, renaming} { catch {interp delete a} interp create a @@ -860,196 +952,153 @@ test interp-19.9 {alias deletion, renaming} { } 1156 test interp-20.1 {interp hide, interp expose and interp invokehidden} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - a eval {proc foo {} {}} - a hide foo - catch {a eval foo something} msg - interp delete a + set 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} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - a hide list + 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] - lappend l $msg - a expose list - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - interp delete a + 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} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - a hide list + 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] - lappend l $msg - lappend l [catch {a invokehidden list 1 2 3} msg] - lappend l $msg - a expose list - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - interp delete a + 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 {}} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - a hide list + 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] - lappend l $msg - lappend l [catch {a invokehidden list {"" 1 2 3}} msg] - lappend l $msg - a expose list - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - interp delete a + 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 {}} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - a hide list + 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] - lappend l $msg - lappend l [catch {a invokehidden list {{} 1 2 3}} msg] - lappend l $msg - a expose list - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - interp delete a + 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} { - catch {interp delete a} - interp create a - a hide list + set a [interp create] + $a hide list set l "" set z 45 - lappend l [catch {a invokehidden list $z 1 2 3} msg] - lappend l $msg - a expose list - lappend l [catch {a eval list $z 1 2 3} msg] - lappend l $msg - interp delete a + 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} { - catch {interp delete a} - interp create a - a hide list + set a [interp create] + $a hide list set z 45 - set l "" - lappend l [catch {a invokehidden list {$z a b c}} msg] - lappend l $msg - interp delete a + set l [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} { - catch {interp delete a} - interp create a - a hide list - a eval set z 89 + set a [interp create] + $a hide list + $a eval set z 89 set z 45 - set l "" - lappend l [catch {a invokehidden list {$z a b c}} msg] - lappend l $msg - interp delete a + set l [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} { - catch {interp delete a} - interp create a - a hide list - a eval set z 89 + 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] - lappend l $msg - interp delete a + 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} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - a eval {proc foo {} {}} - interp hide a foo - catch {interp eval a foo something} msg - interp delete a + set 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} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - interp hide a list + 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] - lappend l $msg - interp expose a list - lappend l [catch {interp eval a {list 1 2 3}} msg] - lappend l $msg - interp delete a + 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} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - interp hide a list + 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] - lappend l $msg - lappend l [catch {interp invokehidden a list 1 2 3} msg] - lappend l $msg - interp expose a list - lappend l [catch {interp eval a {list 1 2 3}} msg] - lappend l $msg - interp delete a + 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 {}} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - interp hide a list + 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] - lappend l $msg - lappend l [catch {interp invokehidden a list {"" 1 2 3}} msg] - lappend l $msg - interp expose a list - lappend l [catch {interp eval a {list 1 2 3}} msg] - lappend l $msg - interp delete a + 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 {}} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - interp hide a list + 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] - lappend l $msg - lappend l [catch {interp invokehidden a list {{} 1 2 3}} msg] - lappend l $msg - interp expose a list - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - interp delete a + 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} { @@ -1540,6 +1589,19 @@ test interp-20.48 {interp hide vs namespaces} { interp delete a set l } {1 {cannot use namespace qualifiers in hidden command token (rename)}} +test interp-20.49 {interp invokehidden -namespace} -setup { + set script [makeFile { + set x [namespace current] + } script] + interp create -safe slave +} -body { + slave invokehidden -namespace ::foo source $script + slave eval {set ::foo::x} +} -cleanup { + interp delete slave + removeFile script +} -result ::foo + test interp-21.1 {interp hidden} { interp hidden {} @@ -1730,35 +1792,17 @@ test interp-23.2 {testing hiding vs aliases} {unixOrPc} { set l "" lappend l [lsort [interp hidden a]] a alias bar bar - lappend l [interp aliases a] - lappend l [lsort [interp hidden a]] - a hide bar - lappend l [interp aliases a] - lappend l [lsort [interp hidden a]] - a alias bar {} - lappend l [interp aliases a] - lappend l [lsort [interp hidden a]] - interp delete a - set l -} {{cd encoding exec exit fconfigure file glob load open pwd socket source} bar {cd encoding exec exit fconfigure file glob load open pwd socket source} bar {bar cd encoding exec exit fconfigure file glob load open pwd socket source} {} {cd encoding exec exit fconfigure file glob load open pwd socket source}} - -test interp-23.3 {testing hiding vs aliases} {macOnly} { - catch {interp delete a} - interp create a -safe - set l "" - lappend l [lsort [interp hidden a]] - a alias bar bar - lappend l [interp aliases a] + lappend l [lsort [interp aliases a]] lappend l [lsort [interp hidden a]] a hide bar - lappend l [interp aliases a] + lappend l [lsort [interp aliases a]] lappend l [lsort [interp hidden a]] a alias bar {} - lappend l [interp aliases a] + lappend l [lsort [interp aliases a]] lappend l [lsort [interp hidden a]] interp delete a set l -} {{beep cd echo encoding exit fconfigure file glob load ls open pwd socket source} bar {beep cd echo encoding exit fconfigure file glob load ls open pwd socket source} bar {bar beep cd echo encoding exit fconfigure file glob load ls open pwd socket source} {} {beep cd echo encoding exit fconfigure file glob load ls open pwd socket source}} +} {{cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {bar cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload}} test interp-24.1 {result resetting on error} { catch {interp delete a} @@ -1774,6 +1818,7 @@ test interp-24.1 {result resetting on error} { set l }] interp delete a + rename foo {} set l } {1 {1 2 3} 1 {3 4 5}} test interp-24.2 {result resetting on error} { @@ -1790,6 +1835,7 @@ test interp-24.2 {result resetting on error} { set l }] interp delete a + rename foo {} set l } {1 {1 2 3} 1 {3 4 5}} test interp-24.3 {result resetting on error} { @@ -2083,7 +2129,7 @@ test interp-26.6 {result code transmission: all combined--bug 1637} \ proc MyTestAlias {interp args} { global aliasTrace; lappend aliasTrace $args; - eval interp invokehidden [list $interp] $args + interp invokehidden $interp {*}$args } foreach c {return} { interp hide $interp $c; @@ -2113,7 +2159,7 @@ test interp-26.7 {errorInfo transmission: regular interps} { MyError "some secret" } interp alias $interp test {} MyTestAlias $interp; - set res [interp eval $interp {catch test;set errorInfo}] + set res [interp eval $interp {catch test;set ::errorInfo}] interp delete $interp; set res } {msg @@ -2136,7 +2182,7 @@ test interp-26.8 {errorInfo transmission: safe interps--bug 1637} {knownBug} { MyError "some secret" } interp alias $interp test {} MyTestAlias $interp; - set res [interp eval $interp {catch test;set errorInfo}] + set res [interp eval $interp {catch test;set ::errorInfo}] interp delete $interp; set res } {msg @@ -2321,6 +2367,23 @@ test interp-28.1 {getting fooled by slave's namespace ?} { set r } {} +test interp-28.2 {master's nsName cache should not cross} { + set i [interp create] + set res [$i eval { + set x {namespace children ::} + set y [list namespace children ::] + namespace delete [{*}$y] + set j [interp create] + $j eval {namespace delete {*}[namespace children ::]} + namespace eval foo {} + set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]] + interp delete $j + set res + }] + interp delete $i + set res +} {::foo ::foo {} {}} + # Part 29: recursion limit # 29.1.* Argument checking # 29.2.* Reading and setting the recursion limit @@ -2908,8 +2971,7 @@ test interp-31.1 {alias invocation scope} { set result } ok -test interp-32.1 { parent's working directory should - be inherited by a child interp } { +test interp-32.1 {parent's working directory should be inherited by a child interp} { cd [temporaryDirectory] set parent [pwd] set i [interp create] @@ -2935,12 +2997,563 @@ test interp-33.1 {refCounting for target words of alias [Bug 730244]} { # 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 + $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 ?options?"} +test interp-35.2 {interp limit syntax} -body { + interp limit {} +} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"} +test interp-35.3 {interp limit syntax} -body { + interp limit {} foo +} -returnCodes error -result {bad limit type "foo": must be commands or time} +test interp-35.4 {interp limit syntax} -body { + set i [interp create] + set dict [interp limit $i commands] + set result {} + foreach key [lsort [dict keys $dict]] { + lappend result $key [dict get $dict $key] + } + set result +} -cleanup { + interp delete $i +} -result {-command {} -granularity 1 -value {}} +test interp-35.5 {interp limit syntax} -body { + set i [interp create] + interp limit $i commands -granularity +} -cleanup { + interp delete $i +} -result 1 +test interp-35.6 {interp limit syntax} -body { + set i [interp create] + interp limit $i commands -granularity 2 +} -cleanup { + interp delete $i +} -result {} +test interp-35.7 {interp limit syntax} -body { + set i [interp create] + interp limit $i commands -foobar +} -cleanup { + interp delete $i +} -returnCodes error -result {bad option "-foobar": must be -command, -granularity, or -value} +test interp-35.8 {interp limit syntax} -body { + set i [interp create] + interp limit $i commands -granularity foobar +} -cleanup { + interp delete $i +} -returnCodes error -result {expected integer but got "foobar"} +test interp-35.9 {interp limit syntax} -body { + set i [interp create] + interp limit $i commands -granularity 0 +} -cleanup { + interp delete $i +} -returnCodes error -result {granularity must be at least 1} +test interp-35.10 {interp limit syntax} -body { + set i [interp create] + interp limit $i commands -value foobar +} -cleanup { + interp delete $i +} -returnCodes error -result {expected integer but got "foobar"} +test interp-35.11 {interp limit syntax} -body { + set i [interp create] + interp limit $i commands -value -1 +} -cleanup { + interp delete $i +} -returnCodes error -result {command limit value must be at least 0} +test interp-35.12 {interp limit syntax} -body { + set i [interp create] + set dict [interp limit $i time] + set result {} + foreach key [lsort [dict keys $dict]] { + lappend result $key [dict get $dict $key] + } + set result +} -cleanup { + interp delete $i +} -result {-command {} -granularity 10 -milliseconds {} -seconds {}} +test interp-35.13 {interp limit syntax} -body { + set i [interp create] + interp limit $i time -granularity +} -cleanup { + interp delete $i +} -result 10 +test interp-35.14 {interp limit syntax} -body { + set i [interp create] + interp limit $i time -granularity 2 +} -cleanup { + interp delete $i +} -result {} +test interp-35.15 {interp limit syntax} -body { + set i [interp create] + interp limit $i time -foobar +} -cleanup { + interp delete $i +} -returnCodes error -result {bad option "-foobar": must be -command, -granularity, -milliseconds, or -seconds} +test interp-35.16 {interp limit syntax} -body { + set i [interp create] + interp limit $i time -granularity foobar +} -cleanup { + interp delete $i +} -returnCodes error -result {expected integer but got "foobar"} +test interp-35.17 {interp limit syntax} -body { + set i [interp create] + interp limit $i time -granularity 0 +} -cleanup { + interp delete $i +} -returnCodes error -result {granularity must be at least 1} +test interp-35.18 {interp limit syntax} -body { + set i [interp create] + interp limit $i time -seconds foobar +} -cleanup { + interp delete $i +} -returnCodes error -result {expected integer but got "foobar"} +test interp-35.19 {interp limit syntax} -body { + set i [interp create] + interp limit $i time -seconds -1 +} -cleanup { + interp delete $i +} -returnCodes error -result {seconds must be at least 0} +test interp-35.20 {interp limit syntax} -body { + set i [interp create] + interp limit $i time -millis foobar +} -cleanup { + interp delete $i +} -returnCodes error -result {expected integer but got "foobar"} +test interp-35.21 {interp limit syntax} -body { + set i [interp create] + interp limit $i time -millis -1 +} -cleanup { + interp delete $i +} -returnCodes error -result {milliseconds must be at least 0} +test interp-35.22 {interp time limits normalize milliseconds} -body { + set i [interp create] + interp limit $i time -seconds 1 -millis 1500 + list [$i limit time -seconds] [$i limit time -millis] +} -cleanup { + interp delete $i +} -result {2 500} +# Bug 3398794 +test interp-35.23 {interp command limits can't touch current interp} -body { + interp limit {} commands -value 10 +} -returnCodes error -result {limits on current interpreter inaccessible} +test interp-35.24 {interp time limits can't touch current interp} -body { + interp limit {} time -seconds 2 +} -returnCodes error -result {limits on current interpreter inaccessible} + +test interp-36.1 {interp bgerror syntax} -body { + interp bgerror +} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} +test interp-36.2 {interp bgerror syntax} -body { + interp bgerror x y z +} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} +test interp-36.3 {interp bgerror syntax} -setup { + interp create slave +} -body { + slave bgerror x y +} -cleanup { + interp delete slave +} -returnCodes error -result {wrong # args: should be "slave bgerror ?cmdPrefix?"} +test interp-36.4 {SlaveBgerror syntax} -setup { + interp create slave +} -body { + slave bgerror \{ +} -cleanup { + interp delete slave +} -returnCodes error -result {cmdPrefix must be list of length >= 1} +test interp-36.5 {SlaveBgerror syntax} -setup { + interp create slave +} -body { + slave bgerror {} +} -cleanup { + interp delete slave +} -returnCodes error -result {cmdPrefix must be list of length >= 1} +test interp-36.6 {SlaveBgerror returns handler} -setup { + interp create slave +} -body { + slave bgerror {foo bar soom} +} -cleanup { + interp delete slave +} -result {foo bar soom} + +test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { + interp create slave + slave alias handler handler + slave bgerror handler + variable result {untouched} + proc handler {args} { + variable result + set result [lindex $args 0] + } +} -body { + slave eval { + variable done {} + after 0 error foo + after 10 [list ::set [namespace which -variable done] {}] + vwait [namespace which -variable done] + } + set result +} -cleanup { + variable result {} + unset result + interp delete slave +} -result foo + +test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { + catch {interp delete a} + interp create a + set result {} +} -body { + interp create {a b} -safe + lappend result [interp eval a {expr min(5,2,3)*max(7,13,11)}] + lappend result [interp eval {a b} {expr min(5,2,3)*max(7,13,11)}] +} -cleanup { + unset 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 ::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} -body { + interp debug {} +} -result {-frame 0} +test interp-38.5 {interp debug basic setup} -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 foreach i [interp slaves] { - interp delete $i + interp delete $i } ::tcltest::cleanupTests return |