summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2004-11-03 17:16:03 (GMT)
committerdgp <dgp@users.sourceforge.net>2004-11-03 17:16:03 (GMT)
commitf6daa6116e683fc15534f46a414da180d25bf7fa (patch)
tree522f2260bb6a7f37ff62d01a10eeafec32d324aa /generic
parente82130fc14b54af2b6d23fd1ef721761b3eb2ed0 (diff)
downloadtcl-f6daa6116e683fc15534f46a414da180d25bf7fa.zip
tcl-f6daa6116e683fc15534f46a414da180d25bf7fa.tar.gz
tcl-f6daa6116e683fc15534f46a414da180d25bf7fa.tar.bz2
* generic/tclTrace.c (TclCallVarTraces): Improved ability to debug
* tests/incr-old.test (incr-old-2.6): errors during variable * tests/incr.test (incr-{1,2}.28): traces by preserving the * tests/set.test (set-{2,4}.4): -errorinfo data. * tests/trace.test (trace-33.1): [Bug 527164]
Diffstat (limited to 'generic')
-rw-r--r--generic/tclTrace.c41
1 files changed, 34 insertions, 7 deletions
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 1088f2e..24d9450 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.18 2004/10/25 01:06:51 msofer Exp $
+ * RCS: @(#) $Id: tclTrace.c,v 1.19 2004/11/03 17:16:05 dgp Exp $
*/
#include "tclInt.h"
@@ -2554,19 +2554,33 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
if (code == TCL_ERROR) {
if (leaveErrMsg) {
CONST char *type = "";
+ Tcl_Obj *options = TclGetReturnOptions((Tcl_Interp *)iPtr, code);
+ Tcl_Obj *errorInfoKey = Tcl_NewStringObj("-errorinfo", -1);
+ Tcl_Obj *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: {
+ case TCL_TRACE_READS:
type = "read";
+ Tcl_AppendToObj(errorInfo, type, -1);
break;
- }
- case TCL_TRACE_WRITES: {
+ case TCL_TRACE_WRITES:
type = "set";
+ Tcl_AppendToObj(errorInfo, "write", -1);
break;
- }
- case TCL_TRACE_ARRAY: {
+ case TCL_TRACE_ARRAY:
type = "trace array";
+ Tcl_AppendToObj(errorInfo, "array", -1);
break;
- }
}
if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type,
@@ -2574,6 +2588,19 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
} 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 = TclSetReturnOptions((Tcl_Interp *)iPtr, options);
+ iPtr->flags &= ~(ERR_ALREADY_LOGGED);
TclDiscardInterpState(state);
} else {
(void) TclRestoreInterpState((Tcl_Interp *)iPtr, state);