diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | generic/tclTrace.c | 60 | ||||
| -rw-r--r-- | generic/tclVar.c | 13 |
3 files changed, 39 insertions, 44 deletions
@@ -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-06 Jan Nijtmans <nijtmans@users.sf.net> * tclWinTest.c: Fix compiler warning when compiling this file with mingw gcc: diff --git a/generic/tclTrace.c b/generic/tclTrace.c index dfcac43..bc6d289 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.47 2007/12/13 15:23:20 dgp Exp $ + * RCS: @(#) $Id: tclTrace.c,v 1.47.2.1 2008/10/08 14:52:39 dgp Exp $ */ #include "tclInt.h" @@ -2667,53 +2667,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 43f0324..dc6699e 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.160.2.2 2008/08/07 01:44:31 dgp Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.160.2.3 2008/10/08 14:52:39 dgp Exp $ */ #include "tclInt.h" @@ -4660,16 +4660,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)); } /* |