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-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)); } /* |