Rebase bug-fix for [554117edde] to latest 8.6. For evaluation

generic/tclInt.h

@@ -4016,6 +4016,8 @@ MODULE_SCOPE int	TclCompileAssembleCmd(Tcl_Interp *interp,
  * the public interface.
  */
 
+MODULE_SCOPE Tcl_Obj *	TclObjGetVarScalarNoTrace(Tcl_Interp *interp,
+			    Tcl_Obj *namePtr, int flags);
 MODULE_SCOPE Var *	TclObjLookupVarEx(Tcl_Interp * interp,
 			    Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags,
 			    const char *msg, int createPart1,

generic/tclResult.c

@@ -81,14 +81,23 @@ Tcl_SaveInterpState(
     statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED;
     statePtr->returnLevel = iPtr->returnLevel;
     statePtr->returnCode = iPtr->returnCode;
-    statePtr->errorInfo = iPtr->errorInfo;
+    /* be sure we obtain content of ei/ec vars if states are NULL */
+    if ((statePtr->errorInfo = iPtr->errorInfo) == NULL) {
+	statePtr->flags |= ERR_LEGACY_COPY;
+	statePtr->errorInfo = TclObjGetVarScalarNoTrace(interp, iPtr->eiVar,
+						TCL_GLOBAL_ONLY);
+    }
     statePtr->errorStack = iPtr->errorStack;
     statePtr->resetErrorStack = iPtr->resetErrorStack;
     if (statePtr->errorInfo) {
 	Tcl_IncrRefCount(statePtr->errorInfo);
     }
-    statePtr->errorCode = iPtr->errorCode;
-    if (statePtr->errorCode) {
+    if ((statePtr->errorCode = iPtr->errorCode) == NULL) {
+	statePtr->flags |= ERR_LEGACY_COPY;
+	statePtr->errorCode = TclObjGetVarScalarNoTrace(interp, iPtr->ecVar,
+						TCL_GLOBAL_ONLY);
+    }
+    if ( statePtr->errorCode) {
 	Tcl_IncrRefCount(statePtr->errorCode);
     }
     statePtr->returnOpts = iPtr->returnOpts;
@@ -131,7 +140,7 @@ Tcl_RestoreInterpState(
     int status = statePtr->status;
 
     iPtr->flags &= ~ERR_ALREADY_LOGGED;
-    iPtr->flags |= (statePtr->flags & ERR_ALREADY_LOGGED);
+    iPtr->flags |= (statePtr->flags & (ERR_ALREADY_LOGGED|ERR_LEGACY_COPY));
 
     iPtr->returnLevel = statePtr->returnLevel;
     iPtr->returnCode = statePtr->returnCode;

generic/tclTest.c

@@ -2282,17 +2282,61 @@ TestevalobjvObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
-    int evalGlobal;
+    static const char *const options[] = {
+	"-global", "-safe", "--", NULL
+    };
+    enum options {
+	EOV_Global, EOV_Safe, EOV_End
+    };
+    int ret, index, flags = 0, evalSafe = 0;
+    Tcl_InterpState interpState;
 
-    if (objc < 3) {
-	Tcl_WrongNumArgs(interp, 1, objv, "global word ?word ...?");
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "?-global|0|1? ?-safe? ?--? word ?word ...?");
 	return TCL_ERROR;
     }
-    if (Tcl_GetIntFromObj(interp, objv[1], &evalGlobal) != TCL_OK) {
-	return TCL_ERROR;
+    objc--; objv++;
+    while (objc >= 2) {
+	if (Tcl_GetIndexFromObj(NULL, objv[0], options, "option", TCL_EXACT,
+		&index) == TCL_OK) {
+	    objc--; objv++;
+	    if (index == EOV_Global) {
+		flags |= TCL_EVAL_GLOBAL;
+		continue;
+	    }
+	    if (index == EOV_Safe) {
+		evalSafe = 1;
+		continue;
+	    }
+	    if (index == EOV_End) {
+		break;
+	    }
+	} else if (Tcl_GetIntFromObj(NULL, objv[0], &index) == TCL_OK) {
+	    if (index) {
+		flags |= TCL_EVAL_GLOBAL;
+	    }
+	    objc--; objv++;
+	} else {
+	    break;
+	}
     }
-    return Tcl_EvalObjv(interp, objc-2, objv+2,
-	    (evalGlobal) ? TCL_EVAL_GLOBAL : 0);
+    if (evalSafe) {
+	interpState = Tcl_SaveInterpState(interp, 0);
+    }
+    ret = Tcl_EvalObjv(interp, objc, objv, flags);
+    if (evalSafe) {
+	if (ret != TCL_OK) {
+	    Tcl_DiscardInterpState(interpState);
+	} else {
+	    /* restore state (excepting result) */
+	    Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
+	    Tcl_IncrRefCount(objPtr);
+	    (void) Tcl_RestoreInterpState(interp, interpState);
+	    Tcl_SetObjResult(interp, objPtr);
+	    Tcl_DecrRefCount(objPtr);
+	}
+    }
+    return ret;
 }
 
 /*

generic/tclVar.c

@@ -1352,6 +1352,25 @@ Tcl_ObjGetVar2(
     return TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
 	    flags, -1);
 }
+
+Tcl_Obj *
+TclObjGetVarScalarNoTrace(
+    Tcl_Interp *interp,		/* Command interpreter in which variable is to
+				 * be looked up. */
+    register Tcl_Obj *namePtr,	/* Points to an object holding the name of a
+				 * variable. */
+    int flags)			/* OR-ed combination of TCL_GLOBAL_ONLY and
+				 * TCL_LEAVE_ERR_MSG bits. */
+{
+    Var *varPtr, *arrayPtr;
+
+    varPtr = TclObjLookupVarEx(interp, namePtr, NULL, flags, "read",
+	    /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
+    if (varPtr && TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
+	return varPtr->value.objPtr;
+    }
+    return NULL;
+}
 
 /*
  *----------------------------------------------------------------------

tests/result.test

@@ -24,6 +24,7 @@ testConstraint testsaveresult      [llength [info commands testsaveresult]]
 testConstraint testsetobjerrorcode [llength [info commands testsetobjerrorcode]]
 testConstraint testseterrorcode    [llength [info commands testseterrorcode]]
 testConstraint testreturn          [llength [info commands testreturn]]
+testConstraint testevalobjv        [llength [info commands testevalobjv]]
 
 test result-1.1 {Tcl_SaveInterpResult} {testsaveresult} {
     testsaveresult small {set x 42} 0
@@ -50,6 +51,36 @@ test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} {
     testsaveresult object {set x 42} 1
 } {42 different}
 
+test result-1.9.1 {Tcl_SaveInterpState: "safe" eval without modifying states} {testevalobjv} {
+    if {[catch {
+	return -level 0 -code error -errorcode {EXPERR TEST-ERROR} -errorinfo "ERROR expected error" test
+    }]} {
+	# safe routine (e.g. clock format) that should never overwrite error code/info:
+	testevalobjv -safe catch {
+	    error catched "ERROR in safe block" {UNEXPERR INVISIBLE}
+	}
+	list $::errorCode $::errorInfo
+    }
+} {{EXPERR TEST-ERROR} {ERROR expected error}}
+test result-1.9.2 {Tcl_SaveInterpState: nested save state does not modify error info/code} {testevalobjv} {
+    proc _get_time {} {
+	testevalobjv -safe eval {
+	    # some catched (initialization) error:
+	    testevalobjv -safe catch {
+		error catched "ERROR in safe block" {UNEXPERR INVISIBLE}
+	    }
+	    # clock seconds:
+	    return 0
+	}
+    }
+    if {[catch {
+	return -level 0 -code error -errorcode {EXPERR TEST-ERROR} -errorinfo "ERROR expected error" test
+    }]} {
+	# safe routine _get_time should never overwrite error code/info:
+	list [_get_time] $::errorCode $::errorInfo
+    }
+} {0 {EXPERR TEST-ERROR} {ERROR expected error}}
+
 # Tcl_RestoreInterpResult is mostly tested by the previous tests except
 # for the following case