* tests/execute.test (execute-6.*): More tests checking that

        script bytecode is invalidated in the right situations.

1 files changed, 81 insertions, 2 deletions

diff --git a/tests/execute.test b/tests/execute.test
index 7c4545d..eea8bb4 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -14,7 +14,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: execute.test,v 1.25 2008/03/04 18:50:04 dgp Exp $
+# RCS: @(#) $Id: execute.test,v 1.26 2008/03/07 15:28:28 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -34,6 +34,7 @@ testConstraint testobj [expr {
 }]
 
 testConstraint longIs32bit [expr {int(0x80000000) < 0}]
+testConstraint testevalex [llength [info commands testevalex]]
 
 # Tests for the omnibus TclExecuteByteCode function:
 
@@ -584,7 +585,6 @@ test execute-6.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName o
     }
     p
 } {}
-
 test execute-6.2 {Evaluate an expression in a variable; compile the first time, do not the second} {
     set w {3*5}
     proc a {obj} {expr $obj}
@@ -608,6 +608,85 @@ test execute-6.4 {TclCompEvalObj: don't use cached expr bytecode [Bug 1899164]}
 } -cleanup {
     rename 0+0 {}
 } -result SCRIPT
+test execute-6.5 {TclCompEvalObj: bytecode epoch validation} {
+    set script { llength {} }
+    set result {}
+    lappend result [if 1 $script]
+    set origName [namespace which llength]
+    rename $origName llength.orig
+    proc $origName {args} {return AHA!}
+    lappend result [if 1 $script]
+    rename $origName {}
+    rename llength.orig $origName
+    set result
+} {0 AHA!}
+test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} {
+    proc foo {} {set a 1}
+    set a untouched
+    set result {}
+    lappend result [foo] $a
+    lappend result [if 1 [info body foo]] $a
+    rename foo {}
+    set result
+} {1 untouched 1 1}
+test execute-6.7 {TclCompEvalObj: bytecode context validation} {
+    set script { llength {} }
+    namespace eval foo {
+	proc llength {args} {return AHA!}
+    }
+    set result {}
+    lappend result [if 1 $script]
+    lappend result [namespace eval foo $script]
+    namespace delete foo
+    set result
+} {0 AHA!}
+test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} {
+    set script { llength {} }
+    set result {}
+    lappend result [namespace eval foo $script]
+    namespace eval foo {
+	proc llength {args} {return AHA!}
+    }
+    lappend result [namespace eval foo $script]
+    namespace delete foo
+    set result
+} {0 AHA!}
+test execute-6.9 {TclCompEvalObj: bytecode interp validation} {
+    set script { llength {} }
+    interp create slave
+    slave eval {proc llength args {return AHA!}}
+    set result {}
+    lappend result [if 1 $script]
+    lappend result [slave eval $script]
+    interp delete slave
+    set result
+} {0 AHA!}
+test execute-6.10 {TclCompEvalObj: bytecode interp validation} {
+    set script { llength {} }
+    interp create slave
+    set result {}
+    lappend result [slave eval $script]
+    interp delete slave
+    interp create slave
+    lappend result [slave eval $script]
+    interp delete slave
+    set result
+} {0 0}
+# Still trying to craft this one...
+#test execute-6.11 {Tcl_ExprObj: exprcode interp validation} testevalex {
+#    set e { [llength {}]+1 }
+#    set result {}
+#    interp create slave
+#    load {} Tcltest slave
+#    slave eval [list testevalex [listZZproc e e {set expr expr; $expr $e}}
+#    lappend result [slave eval [list e $e]]
+#    interp delete slave
+#    interp create slave
+#    slave eval {proc e e {expr $e}}
+#    lappend result [slave eval [list e $e]]
+#    interp delete slave
+#    set result
+#} {1 1}
 
 test execute-7.0 {Wide int handling in INST_JUMP_FALSE/LAND} {
     set x 0x100000000