* generic/tclTrace.c: Corrected handling of errors returned by

        variable traces so that the errorInfo value contains the original
        error message.  [Bug 2151707]

        * generic/tclVar.c:     Revised implementation of TclObjVarErrMsg
        so that error message construction does not disturb an existing
        iPtr->errorInfo that may be in progress.

3 files changed, 39 insertions, 44 deletions

diff --git a/ChangeLog b/ChangeLog
index 5bc3901..6ab61fc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2008-10-08  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclTrace.c:	Corrected handling of errors returned by
+	variable traces so that the errorInfo value contains the original
+	error message.  [Bug 2151707]
+
+	* generic/tclVar.c:	Revised implementation of TclObjVarErrMsg
+	so that error message construction does not disturb an existing
+	iPtr->errorInfo that may be in progress.
+
 2008-10-07  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/binary.n: Added better documentation of the [binary encode] and
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 8f095b5..6386f29 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.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: tclTrace.c,v 1.51 2008/09/05 01:20:00 msofer Exp $
+ * RCS: @(#) $Id: tclTrace.c,v 1.52 2008/10/08 14:50:57 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -2672,53 +2672,41 @@ TclCallVarTraces(
   done:
     if (code == TCL_ERROR) {
 	if (leaveErrMsg) {
+	    const char *verb = "";
 	    const char *type = "";
-	    Tcl_Obj *options = Tcl_GetReturnOptions((Tcl_Interp *)iPtr, code);
-	    Tcl_Obj *errorInfoKey, *errorInfo;
-
-	    TclNewLiteralStringObj(errorInfoKey, "-errorinfo");
-	    Tcl_IncrRefCount(errorInfoKey);
-	    Tcl_DictObjGet(NULL, options, errorInfoKey, &errorInfo);
-	    Tcl_IncrRefCount(errorInfo);
-	    Tcl_DictObjRemove(NULL, options, errorInfoKey);
-	    if (Tcl_IsShared(errorInfo)) {
-		Tcl_DecrRefCount(errorInfo);
-		errorInfo = Tcl_DuplicateObj(errorInfo);
-		Tcl_IncrRefCount(errorInfo);
-	    }
-	    Tcl_AppendToObj(errorInfo, "\n    (", -1);
+
 	    switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) {
 	    case TCL_TRACE_READS:
-		type = "read";
-		Tcl_AppendToObj(errorInfo, type, -1);
+		verb = "read";
+		type = verb;
 		break;
 	    case TCL_TRACE_WRITES:
-		type = "set";
-		Tcl_AppendToObj(errorInfo, "write", -1);
+		verb = "set";
+		type = "write";
 		break;
 	    case TCL_TRACE_ARRAY:
-		type = "trace array";
-		Tcl_AppendToObj(errorInfo, "array", -1);
+		verb = "trace array";
+		type = "array";
 		break;
 	    }
+
 	    if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
-		TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type,
+		Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result);
+	    } else {
+		Tcl_SetResult((Tcl_Interp *)iPtr, result, TCL_STATIC);
+	    }
+	    Tcl_AddErrorInfo((Tcl_Interp *)iPtr, "");
+
+	    Tcl_AppendObjToErrorInfo((Tcl_Interp *)iPtr, Tcl_ObjPrintf(
+		    "\n    (%s trace on \"%s%s%s%s\")", type, part1,
+		    (part2 ? "(" : ""), (part2 ? part2 : ""),
+		    (part2 ? ")" : "") ));
+	    if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
+		TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb,
 			Tcl_GetString((Tcl_Obj *) result));
 	    } else {
-		TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result);
-	    }
-	    Tcl_AppendToObj(errorInfo, " trace on \"", -1);
-	    Tcl_AppendToObj(errorInfo, part1, -1);
-	    if (part2 != NULL) {
-		Tcl_AppendToObj(errorInfo, "(", -1);
-		Tcl_AppendToObj(errorInfo, part1, -1);
-		Tcl_AppendToObj(errorInfo, ")", -1);
-	    }
-	    Tcl_AppendToObj(errorInfo, "\")", -1);
-	    Tcl_DictObjPut(NULL, options, errorInfoKey, errorInfo);
-	    Tcl_DecrRefCount(errorInfoKey);
-	    Tcl_DecrRefCount(errorInfo);
-	    code = Tcl_SetReturnOptions((Tcl_Interp *) iPtr, options);
+		TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, result);
+	    }
 	    iPtr->flags &= ~(ERR_ALREADY_LOGGED);
 	    Tcl_DiscardInterpState(state);
 	} else {
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 15b1856..a359711 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -16,7 +16,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclVar.c,v 1.168 2008/09/25 19:51:29 dgp Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.169 2008/10/08 14:50:57 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -4641,16 +4641,13 @@ TclObjVarErrMsg(
 				 * variable, or -1. Only used when part1Ptr is
 				 * NULL. */
 {
-    Tcl_ResetResult(interp);
     if (!part1Ptr) {
 	part1Ptr = localName(((Interp *)interp)->varFramePtr, index);
     }
-    Tcl_AppendResult(interp, "can't ", operation, " \"",
-	    TclGetString(part1Ptr), NULL);
-    if (part2Ptr) {
-	Tcl_AppendResult(interp, "(", TclGetString(part2Ptr), ")", NULL);
-    }
-    Tcl_AppendResult(interp, "\": ", reason, NULL);
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't %s \"%s%s%s%s\": %s",
+	    operation, TclGetString(part1Ptr), (part2Ptr ? "(" : ""),
+	    (part2Ptr ? TclGetString(part2Ptr) : ""), (part2Ptr ? ")" : ""),
+	    reason));
 }
 
 /*