diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/interp.test | 299 |
1 files changed, 151 insertions, 148 deletions
diff --git a/tests/interp.test b/tests/interp.test index e6b2024..bf49282 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: interp.test,v 1.27 2004/03/30 16:22:22 msofer Exp $ +# RCS: @(#) $Id: interp.test,v 1.28 2004/05/13 12:59:23 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -31,7 +31,7 @@ test interp-1.1 {options for interp command} { } {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, create, 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 } "" @@ -49,13 +49,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, create, 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, create, 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, create, 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"}} @@ -855,196 +855,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} { @@ -2907,16 +2864,62 @@ test interp-32.1 { parent's working directory should test interp-33.1 {refCounting for target words of alias [Bug 730244]} { # This test will panic if Bug 730244 is not fixed. - interp create i - proc test args {return $args} - trace add execution test enter {interp alias i alias {} ;#} - interp alias i alias {} test this - i eval alias + 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} { + 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 + set msg [list [catch {$i eval foobar} msg] $msg] + interp delete $i + set msg +} {1 {command count limit exceeded}} +test interp-34.2 {basic test of limits - bytecoded commands} knownBug { + 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 + set msg [list [catch {$i eval foobar} msg] $msg] + interp delete $i + set msg +} {1 {command count limit exceeded}} +test interp-34.3 {basic test of limits - pure bytecode loop} knownBug { + set i [interp create] + $i eval { + proc foobar {} { + while {1} { + # No bytecode at all here... + } + } + } + $i limit command -value 1000 + set msg [list [catch {$i eval foobar} msg] $msg] + interp delete $i + set msg +} {1 {command count limit exceeded}} + # cleanup foreach i [interp slaves] { - interp delete $i + interp delete $i } ::tcltest::cleanupTests return |