* 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, 90 insertions, 18 deletions

diff --git a/ChangeLog b/ChangeLog
index f4e8199..fa45934 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-10  Don Porter  <dgp@users.sourceforge.net>
 
 	* library/opt/optparse.tcl:	Overlooked dependence of opt 0.4.4
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 15a5c7a..10980db 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.94.2.4 2003/08/05 16:19:54 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.94.2.5 2003/09/19 18:43:00 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -1399,8 +1399,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();
 
@@ -1428,12 +1428,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;
@@ -1463,12 +1473,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;
@@ -1477,8 +1497,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) {
@@ -1907,7 +1927,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;
 	    }
 	    FORCE_LONG(valuePtr, i, w);
@@ -1949,8 +1971,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;
@@ -2164,7 +2188,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;
 	    }
 	}
@@ -2191,7 +2217,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;
 	    }
 	}
@@ -2917,7 +2945,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;
 	    }
 	}
@@ -2932,7 +2962,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;
 	    }
 	}
@@ -3175,7 +3207,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;
@@ -3207,7 +3241,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;
@@ -3253,7 +3289,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;
 	    }
@@ -3393,7 +3431,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;
@@ -3466,7 +3506,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;
 		}
 	    }
@@ -3556,7 +3598,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;
 	    }
 	}
@@ -3721,7 +3765,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;
 		}
@@ -3741,13 +3787,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;
@@ -3949,14 +3999,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:
@@ -3974,10 +4027,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;
 	
@@ -4067,7 +4123,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..2f7363c 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.13.2.1 2003/09/19 18:43:00 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