TIP#143 implementation; still needs docs and more tests...

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