* generic/tclExecute.c: adding (DE)CACHE_STACK_INFO() pairs to protect all calls that may cause traces on ::errorInfo or ::errorCode to corrupt the stack [Bug 804681]

----------------------------------------------------------------------

3 files changed, 93 insertions, 19 deletions

diff --git a/ChangeLog b/ChangeLog
index c864a72..327c36e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2003-09-19  Miguel Sofer <msofer@users.sf.net>
+
+	* generic/tclExecute.c: adding (DE)CACHE_STACK_INFO() pairs to
+	protect all calls that may cause traces on ::errorInfo or
+	::errorCode to corrupt the stack [Bug 804681]
+
 2003-09-17  Vince Darley  <vincentdarley@users.sourceforge.net>
 
 	* tclPathObj.c: fix to test-suite problem introduced by the bug 
@@ -223,7 +229,7 @@
 
 2003-08-05  Miguel Sofer <msofer@users.sf.net>
 
-	* generic/tclexecute.c (INST_INVOKE, INST_EVAL, INST_PUSH_RESULT):
+	* generic/tclExecute.c (INST_INVOKE, INST_EVAL, INST_PUSH_RESULT):
 	added a Tcl_ResetResult(interp) at each point where the interp's
 	result is pushed onto the stack, to avoid keeping an extra
 	reference that may cause costly Tcl_Obj duplication [Bug 781585]
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 316d831..5eb2262 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -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: tclExecute.c,v 1.106 2003/09/12 23:55:32 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.107 2003/09/19 18:09:41 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -1409,8 +1409,8 @@ TclExecuteByteCode(interp, codePtr)
 	     * Finally, let TclEvalObjvInternal handle the command. 
 	     */
 
-	    Tcl_ResetResult(interp);
 	    DECACHE_STACK_INFO();
+	    Tcl_ResetResult(interp);
 	    result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
 	    CACHE_STACK_INFO();
 
@@ -1438,12 +1438,22 @@ TclExecuteByteCode(interp, codePtr)
 
 		/*
 		 * Reset the interp's result to avoid possible duplications
-		 * of large objects [Bug 781585]; be careful to increase its
-		 * refCount before resetting the result.
+		 * of large objects [Bug 781585]. We do not call
+		 * Tcl_ResetResult() to avoid any side effects caused by
+		 * the resetting of errorInfo and errorCode [Bug 804681], 
+		 * which are not needed here. We chose instead to manipulate
+		 * the interp's object result directly.
+		 *
+		 * Note that the result object is now in objResultPtr, it
+		 * keeps the refCount it had in its role of iPtr->objResultPtr.
 		 */
+		{
+		    Tcl_Obj *newObjResultPtr;
+		    TclNewObj(newObjResultPtr);
+		    Tcl_IncrRefCount(newObjResultPtr);
+		    iPtr->objResultPtr = newObjResultPtr;
+		}
 
-		Tcl_IncrRefCount(objResultPtr);
-		Tcl_ResetResult(interp);
 		NEXT_INST_V(pcAdjustment, opnd, -1);
 	    } else {
 		cleanup = opnd;
@@ -1473,12 +1483,22 @@ TclExecuteByteCode(interp, codePtr)
 
 	    /*
 	     * Reset the interp's result to avoid possible duplications
-	     * of large objects [Bug 781585]; be careful to increase its
-	     * refCount before resetting the result.
+	     * of large objects [Bug 781585]. We do not call
+	     * Tcl_ResetResult() to avoid any side effects caused by
+	     * the resetting of errorInfo and errorCode [Bug 804681], 
+	     * which are not needed here. We chose instead to manipulate
+	     * the interp's object result directly.
+	     *
+	     * Note that the result object is now in objResultPtr, it
+	     * keeps the refCount it had in its role of iPtr->objResultPtr.
 	     */
-	    
-	    Tcl_IncrRefCount(objResultPtr);
-	    Tcl_ResetResult(interp);
+	    {
+	        Tcl_Obj *newObjResultPtr;
+		TclNewObj(newObjResultPtr);
+		Tcl_IncrRefCount(newObjResultPtr);
+		iPtr->objResultPtr = newObjResultPtr;
+	    }
+
 	    NEXT_INST_F(1, 1, -1);
 	} else {
 	    cleanup = 1;
@@ -1487,8 +1507,8 @@ TclExecuteByteCode(interp, codePtr)
 
     case INST_EXPR_STK:
 	objPtr = stackPtr[stackTop];
-	Tcl_ResetResult(interp);
 	DECACHE_STACK_INFO();
+	Tcl_ResetResult(interp);
 	result = Tcl_ExprObj(interp, objPtr, &valuePtr);
 	CACHE_STACK_INFO();
 	if (result != TCL_OK) {
@@ -1919,7 +1939,9 @@ TclExecuteByteCode(interp, codePtr)
 	    if (result != TCL_OK) {
 		TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
 		        opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
+		DECACHE_STACK_INFO();
 		Tcl_AddErrorInfo(interp, "\n    (reading increment)");
+		CACHE_STACK_INFO();
 		goto checkForCatch;
 	    }
 	    isWide = (valuePtr->typePtr == &tclWideIntType);
@@ -1962,8 +1984,10 @@ TclExecuteByteCode(interp, codePtr)
 	varPtr = TclObjLookupVar(interp, objPtr, part2, 
 	        TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr);
 	if (varPtr == NULL) {
+	    DECACHE_STACK_INFO();
 	    Tcl_AddObjErrorInfo(interp,
 	            "\n    (reading value of variable to increment)", -1);
+	    CACHE_STACK_INFO();
 	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
 	    result = TCL_ERROR;
 	    goto checkForCatch;
@@ -2202,7 +2226,9 @@ TclExecuteByteCode(interp, codePtr)
 	    if (result != TCL_OK) {
 		TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
 		        (t1Ptr? t1Ptr->name : "null")));
+		DECACHE_STACK_INFO();
 		IllegalExprOperandType(interp, pc, valuePtr);
+		CACHE_STACK_INFO();
 		goto checkForCatch;
 	    }
 	}
@@ -2229,7 +2255,9 @@ TclExecuteByteCode(interp, codePtr)
 	    if (result != TCL_OK) {
 		TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
 		        (t2Ptr? t2Ptr->name : "null")));
+		DECACHE_STACK_INFO();
 		IllegalExprOperandType(interp, pc, value2Ptr);
+		CACHE_STACK_INFO();
 		goto checkForCatch;
 	    }
 	}
@@ -2955,7 +2983,9 @@ TclExecuteByteCode(interp, codePtr)
 		        O2S(valuePtr), O2S(value2Ptr), 
 		        (valuePtr->typePtr? 
 			     valuePtr->typePtr->name : "null")));
+		DECACHE_STACK_INFO();
 		IllegalExprOperandType(interp, pc, valuePtr);
+		CACHE_STACK_INFO();
 		goto checkForCatch;
 	    }
 	}
@@ -2970,7 +3000,9 @@ TclExecuteByteCode(interp, codePtr)
 		        O2S(valuePtr), O2S(value2Ptr),
 		        (value2Ptr->typePtr?
 			    value2Ptr->typePtr->name : "null")));
+		DECACHE_STACK_INFO();
 		IllegalExprOperandType(interp, pc, value2Ptr);
+		CACHE_STACK_INFO();
 		goto checkForCatch;
 	    }
 	}
@@ -3214,7 +3246,9 @@ TclExecuteByteCode(interp, codePtr)
 		        s, O2S(valuePtr),
 		        (valuePtr->typePtr?
 			    valuePtr->typePtr->name : "null")));
+		DECACHE_STACK_INFO();
 		IllegalExprOperandType(interp, pc, valuePtr);
+		CACHE_STACK_INFO();
 		goto checkForCatch;
 	    }
 	    t1Ptr = valuePtr->typePtr;
@@ -3246,7 +3280,9 @@ TclExecuteByteCode(interp, codePtr)
 		        O2S(value2Ptr), s,
 		        (value2Ptr->typePtr?
 			    value2Ptr->typePtr->name : "null")));
+		DECACHE_STACK_INFO();
 		IllegalExprOperandType(interp, pc, value2Ptr);
+		CACHE_STACK_INFO();
 		goto checkForCatch;
 	    }
 	    t2Ptr = value2Ptr->typePtr;
@@ -3299,7 +3335,9 @@ TclExecuteByteCode(interp, codePtr)
 	    if (IS_NAN(dResult) || IS_INF(dResult)) {
 		TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
 		        O2S(valuePtr), O2S(value2Ptr)));
+		DECACHE_STACK_INFO();
 		TclExprFloatError(interp, dResult);
+		CACHE_STACK_INFO();
 		result = TCL_ERROR;
 		goto checkForCatch;
 	    }
@@ -3470,7 +3508,9 @@ TclExecuteByteCode(interp, codePtr)
 	    if (result != TCL_OK) { 
 		TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
 		        s, (tPtr? tPtr->name : "null")));
+		DECACHE_STACK_INFO();
 		IllegalExprOperandType(interp, pc, valuePtr);
+		CACHE_STACK_INFO();
 		goto checkForCatch;
 	    }
 	    tPtr = valuePtr->typePtr;
@@ -3554,7 +3594,9 @@ TclExecuteByteCode(interp, codePtr)
 		if (result != TCL_OK) {
 		    TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
 		            s, (tPtr? tPtr->name : "null")));
+		    DECACHE_STACK_INFO();
 		    IllegalExprOperandType(interp, pc, valuePtr);
+		    CACHE_STACK_INFO();
 		    goto checkForCatch;
 		}
 	    }
@@ -3644,7 +3686,9 @@ TclExecuteByteCode(interp, codePtr)
 	    if (result != TCL_OK) {   /* try to convert to double */
 		TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
 		        O2S(valuePtr), (tPtr? tPtr->name : "null")));
+		DECACHE_STACK_INFO();
 		IllegalExprOperandType(interp, pc, valuePtr);
+		CACHE_STACK_INFO();
 		goto checkForCatch;
 	    }
 	}
@@ -3820,7 +3864,9 @@ TclExecuteByteCode(interp, codePtr)
 		if (IS_NAN(d) || IS_INF(d)) {
 		    TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
 		            O2S(objResultPtr)));
+		    DECACHE_STACK_INFO();
 		    TclExprFloatError(interp, d);
+		    CACHE_STACK_INFO();
 		    result = TCL_ERROR;
 		    goto checkForCatch;
 		}
@@ -3840,13 +3886,17 @@ TclExecuteByteCode(interp, codePtr)
     }
 	
     case INST_BREAK:
+	DECACHE_STACK_INFO();
 	Tcl_ResetResult(interp);
+	CACHE_STACK_INFO();
 	result = TCL_BREAK;
 	cleanup = 0;
 	goto processExceptionReturn;
 
     case INST_CONTINUE:
+	DECACHE_STACK_INFO();
 	Tcl_ResetResult(interp);
+	CACHE_STACK_INFO();
 	result = TCL_CONTINUE;
 	cleanup = 0;
 	goto processExceptionReturn;
@@ -4048,14 +4098,17 @@ TclExecuteByteCode(interp, codePtr)
     case INST_PUSH_RESULT:
 	objResultPtr = Tcl_GetObjResult(interp);
 	TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
+
 	/*
-	 * Reset the interp's result to avoid possible duplications
-	 * of large objects [Bug 781585]; be careful to increase its
-	 * refCount before resetting the result.
+	 * See the comments at INST_INVOKE_STK
 	 */
+	{
+	    Tcl_Obj *newObjResultPtr;
+	    TclNewObj(newObjResultPtr);
+	    Tcl_IncrRefCount(newObjResultPtr);
+	    iPtr->objResultPtr = newObjResultPtr;
+	}
 
-	Tcl_IncrRefCount(objResultPtr);
-	Tcl_ResetResult(interp);
 	NEXT_INST_F(1, 0, -1);
 
     case INST_PUSH_RETURN_CODE:
@@ -4073,10 +4126,13 @@ TclExecuteByteCode(interp, codePtr)
      */
 	
  divideByZero:
+    DECACHE_STACK_INFO();
     Tcl_ResetResult(interp);
     Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
     Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
             (char *) NULL);
+    CACHE_STACK_INFO();
+
     result = TCL_ERROR;
     goto checkForCatch;
 
@@ -4086,11 +4142,13 @@ TclExecuteByteCode(interp, codePtr)
      */
 
  exponOfZero:
+    DECACHE_STACK_INFO();
     Tcl_ResetResult(interp);
     Tcl_AppendToObj(Tcl_GetObjResult(interp),
 	    "exponentiation of zero by negative power", -1);
     Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
 	    "exponentiation of zero by negative power", (char *) NULL);
+    CACHE_STACK_INFO();
     result = TCL_ERROR;
     goto checkForCatch;
 
@@ -4180,7 +4238,9 @@ TclExecuteByteCode(interp, codePtr)
     if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
 	bytes = GetSrcInfoForPc(pc, codePtr, &length);
 	if (bytes != NULL) {
+	    DECACHE_STACK_INFO();
 	    Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
+            CACHE_STACK_INFO();
 	    iPtr->flags |= ERR_ALREADY_LOGGED;
 	}
     }
diff --git a/tests/execute.test b/tests/execute.test
index ab51d1a..80b65ab 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.13 2003/02/25 16:18:54 msofer Exp $
+# RCS: @(#) $Id: execute.test,v 1.14 2003/09/19 18:09:41 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -713,6 +713,14 @@ test execute-7.34 {Wide int handling} {longIs32bit} {
     expr {wide(0x1) * 1024 * 1024 * 1024 * 1024}
 } 1099511627776
 
+test execute-8.1 {Stack protection} {
+    # If [Bug #804681] has not been properly
+    # taken care of, this should segfault
+    proc whatever args {llength $args}
+    trace add variable ::errorInfo {write unset} whatever
+    catch {expr {1+9/0}}
+} 1
+
 # cleanup
 if {[info commands testobj] != {}} {
    testobj freeallvars