* generic/tclBasic.c: Corrections to be sure that TCL_EVAL_GLOBAL

        * tests/parse.test:     evaluations act the same as [uplevel #0]
        * tests/trace.test:     evaluations, even when execution traces or
        invocations of [::unknown] are present.  [Bug 1439836].

4 files changed, 100 insertions, 13 deletions

diff --git a/ChangeLog b/ChangeLog
index 7ab9659..4b00641 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2006-02-28  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclBasic.c:	Corrections to be sure that TCL_EVAL_GLOBAL
+	* tests/parse.test:	evaluations act the same as [uplevel #0]
+	* tests/trace.test:	evaluations, even when execution traces or
+	invocations of [::unknown] are present.  [Bug 1439836].
+
 2006-02-16  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclIndexObj.c:	Disallow the "ambiguous" error message
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b3474bb..f70af71 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclBasic.c,v 1.75.2.19 2005/11/18 23:07:26 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.75.2.20 2006/02/28 15:44:35 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -3034,7 +3034,8 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags)
 	        code = TCL_ERROR;
 	    } else {
 	        iPtr->numLevels++;
-	        code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0);
+	        code = TclEvalObjvInternal(interp, objc+1, newObjv,
+			command, length, flags);
 	        iPtr->numLevels--;
 	    }
 	    Tcl_DecrRefCount(newObjv[0]);
@@ -3053,6 +3054,10 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags)
              * any existing traces, then the set checkTraces to 0 and
              * go through this while loop one more time.
              */
+	    savedVarFramePtr = iPtr->varFramePtr;
+	    if (flags & TCL_EVAL_GLOBAL) {
+		iPtr->varFramePtr = NULL;
+	    }
             if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
                 traceCode = TclCheckInterpTraces(interp, command, length,
                                cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
@@ -3062,6 +3067,7 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags)
                 traceCode = TclCheckExecutionTraces(interp, command, length,
                                cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
             }
+	    iPtr->varFramePtr = savedVarFramePtr;
             cmdPtr->refCount--;
             if (cmdEpoch != cmdPtr->cmdEpoch) {
                 /* The command has been modified in some way */
@@ -3095,6 +3101,10 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags)
     if (!(cmdPtr->flags & CMD_IS_DELETED)) {
 	int saveErrFlags = iPtr->flags 
 		& (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET);
+	savedVarFramePtr = iPtr->varFramePtr;
+	if (flags & TCL_EVAL_GLOBAL) {
+	    iPtr->varFramePtr = NULL;
+	}
         if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
             traceCode = TclCheckExecutionTraces (interp, command, length,
                    cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
@@ -3103,6 +3113,7 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags)
             traceCode = TclCheckInterpTraces(interp, command, length,
                    cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
         }
+	iPtr->varFramePtr = savedVarFramePtr;
 	if (traceCode == TCL_OK) {
 	    iPtr->flags |= saveErrFlags;
 	}
diff --git a/tests/parse.test b/tests/parse.test
index 124ab0f..dae14e9 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -8,10 +8,10 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: parse.test,v 1.11.2.2 2005/03/18 16:33:43 dgp Exp $
+# RCS: @(#) $Id: parse.test,v 1.11.2.3 2006/02/28 15:44:36 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
-    package require tcltest
+    package require tcltest 2
     namespace import -force ::tcltest::*
 }
 
@@ -218,16 +218,17 @@ test parse-7.1 {Tcl_FreeParse and ExpandTokenArray procedures} {
     testparser {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 0
 } {- {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 16 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 {}}
 
-test parse-8.1 {Tcl_EvalObjv procedure} {
+testConstraint testevalobjv [llength [info commands testevalobjv]]
+test parse-8.1 {Tcl_EvalObjv procedure} testevalobjv {
     testevalobjv 0 concat this is a test
 } {this is a test}
-test parse-8.2 {Tcl_EvalObjv procedure, unknown commands} {
+test parse-8.2 {Tcl_EvalObjv procedure, unknown commands} testevalobjv {
     rename unknown unknown.old
     set x [catch {testevalobjv 10 asdf poiu} msg]
     rename unknown.old unknown
     list $x $msg
 } {1 {invalid command name "asdf"}}
-test parse-8.3 {Tcl_EvalObjv procedure, unknown commands} {
+test parse-8.3 {Tcl_EvalObjv procedure, unknown commands} testevalobjv {
     rename unknown unknown.old
     proc unknown args {
 	return "unknown $args"
@@ -237,7 +238,7 @@ test parse-8.3 {Tcl_EvalObjv procedure, unknown commands} {
     rename unknown.old unknown
     list $x $msg
 } {0 {unknown asdf poiu}}
-test parse-8.4 {Tcl_EvalObjv procedure, unknown commands} {
+test parse-8.4 {Tcl_EvalObjv procedure, unknown commands} testevalobjv {
     rename unknown unknown.old
     proc unknown args {
 	error "I don't like that command"
@@ -247,11 +248,11 @@ test parse-8.4 {Tcl_EvalObjv procedure, unknown commands} {
     rename unknown.old unknown
     list $x $msg
 } {1 {I don't like that command}}
-test parse-8.5 {Tcl_EvalObjv procedure, command traces} {
+test parse-8.5 {Tcl_EvalObjv procedure, command traces} testevalobjv {
     testevalobjv 0 set x 123
     testcmdtrace tracetest {testevalobjv 0 set x $x}
 } {{testevalobjv 0 set x $x} {testevalobjv 0 set x 123} {set x 123} {set x 123}}
-test parse-8.7 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL flag} {
+test parse-8.7 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL flag} testevalobjv {
     proc x {} {
 	set y 23
 	set z [testevalobjv 1 set y]
@@ -261,7 +262,7 @@ test parse-8.7 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL flag} {
     set y 16
     x
 } {16 23}
-test parse-8.8 {Tcl_EvalObjv procedure, async handlers} {
+test parse-8.8 {Tcl_EvalObjv procedure, async handlers} testevalobjv {
     proc async1 {result code} {
 	global aresult acode
 	set aresult $result
@@ -275,9 +276,43 @@ test parse-8.8 {Tcl_EvalObjv procedure, async handlers} {
     testasync delete
     set x
 } {0 {new result} 0 original}
-test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} {
+test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} testevalobjv {
     list [catch {testevalobjv 0 error message} msg] $msg
 } {1 message}
+test parse-8.10 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL} testevalobjv {
+    rename ::unknown unknown.save
+    proc ::unknown args {lappend ::info [info level]}
+    catch {rename ::noSuchCommand {}}
+    set ::info {}
+    namespace eval test_ns_1 {
+	testevalobjv 1 noSuchCommand
+	uplevel #0 noSuchCommand
+    }
+    namespace delete test_ns_1
+    rename ::unknown {}
+    rename unknown.save ::unknown
+    set ::info
+} {1 1}
+test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv {
+    rename ::unknown unknown.save
+    proc ::unknown args {lappend ::info [info level]; uplevel 1 foo}
+    proc ::foo args {lappend ::info global}
+    catch {rename ::noSuchCommand {}}
+    set ::slave [interp create]
+    $::slave alias bar noSuchCommand
+    set ::info {}
+    namespace eval test_ns_1 {
+	proc foo args {lappend ::info namespace}
+	$::slave eval bar
+	testevalobjv 1 [list $::slave eval bar]
+	uplevel #0 [list $::slave eval bar]
+    }
+    namespace delete test_ns_1
+    rename ::foo {}
+    rename ::unknown {}
+    rename unknown.save ::unknown
+    set ::info
+} [subst {[set level 2; incr level [info level]] namespace 1 global 1 global}]
 
 test parse-9.1 {Tcl_LogCommandInfo, line numbers} {
     catch {unset x}
diff --git a/tests/trace.test b/tests/trace.test
index 4409fe1..21536ad 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -11,7 +11,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: trace.test,v 1.26.2.14 2005/11/18 23:44:37 msofer Exp $
+# RCS: @(#) $Id: trace.test,v 1.26.2.15 2006/02/28 15:44:36 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -21,6 +21,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 # Used for constraining memory leak tests
 testConstraint memory [llength [info commands memory]]
 
+testConstraint testevalobjv [llength [info commands testevalobjv]]
+
 proc getbytes {} {
     set lines [split [memory info] "\n"]
     lindex [lindex $lines 3] 3
@@ -1590,6 +1592,38 @@ test trace-21.8 {trace execution: leavestep} {
     set info
 } {{foo {set b 3} 0 3 leavestep}}
 
+test trace-21.9 {trace execution: TCL_EVAL_GLOBAL} testevalobjv {
+    trace add execution foo enter soom
+    proc ::soom args {lappend ::info SUCCESS [info level]}
+    set ::info {}
+    namespace eval test_ns_1 {
+        proc soom args {lappend ::info FAIL [info level]}
+        # [testevalobjv 1 ...] ought to produce the same
+	# results as [uplevel #0 ...].
+        testevalobjv 1 foo x
+	uplevel #0 foo x
+    }
+    namespace delete test_ns_1
+    trace remove execution foo enter soom
+    set ::info
+} {SUCCESS 1 SUCCESS 1}
+    
+test trace-21.10 {trace execution: TCL_EVAL_GLOBAL} testevalobjv {
+    trace add execution foo leave soom
+    proc ::soom args {lappend ::info SUCCESS [info level]}
+    set ::info {}
+    namespace eval test_ns_1 {
+        proc soom args {lappend ::info FAIL [info level]}
+        # [testevalobjv 1 ...] ought to produce the same
+	# results as [uplevel #0 ...].
+        testevalobjv 1 foo x
+	uplevel #0 foo x
+    }
+    namespace delete test_ns_1
+    trace remove execution foo leave soom
+    set ::info
+} {SUCCESS 1 SUCCESS 1}
+
 proc factorial {n} {
     if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }
     return 1