summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2008-10-08 14:52:38 (GMT)
committerdgp <dgp@users.sourceforge.net>2008-10-08 14:52:38 (GMT)
commitc0384761647b436730467f41458a6c495532b14b (patch)
tree283b89b06c2ba1a92b8cb7c5a9d3c4406057cc3b
parentdc5c90f4a6e01534ffc03e64ca44c034c87a68df (diff)
downloadtcl-c0384761647b436730467f41458a6c495532b14b.zip
tcl-c0384761647b436730467f41458a6c495532b14b.tar.gz
tcl-c0384761647b436730467f41458a6c495532b14b.tar.bz2
* 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.
-rw-r--r--ChangeLog10
-rw-r--r--generic/tclTrace.c60
-rw-r--r--generic/tclVar.c13
3 files changed, 39 insertions, 44 deletions
diff --git a/ChangeLog b/ChangeLog
index a7491f4..82a7f21 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-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));
}
/*