summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog8
-rw-r--r--generic/tclTrace.c41
-rw-r--r--tests/incr-old.test9
-rw-r--r--tests/incr.test12
-rw-r--r--tests/set.test14
-rw-r--r--tests/trace.test17
6 files changed, 78 insertions, 23 deletions
diff --git a/ChangeLog b/ChangeLog
index 0f376c4..a1305f0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2004-11-03 Don Porter <dgp@users.sourceforge.net>
+
+ * 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]
+
2004-11-02 David Gravereaux <davygrvy@pobox.com>
* generic/tclInt.h: added a check for #ifdef __cplusplus around
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);
diff --git a/tests/incr-old.test b/tests/incr-old.test
index baf5e38..95250f8 100644
--- a/tests/incr-old.test
+++ b/tests/incr-old.test
@@ -13,10 +13,10 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: incr-old.test,v 1.7 2003/03/27 13:19:15 dkf Exp $
+# RCS: @(#) $Id: incr-old.test,v 1.8 2004/11/03 17:16:05 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
@@ -65,13 +65,14 @@ test incr-old-2.5 {incr errors} {
(reading increment)
invoked from within
"incr x 1a"}}
-test incr-old-2.6 {incr errors} {
+test incr-old-2.6 {incr errors} -body {
proc readonly args {error "variable is read-only"}
set x 123
trace var x w readonly
list [catch {incr x 1} msg] $msg $errorInfo
-} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only
+} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
while executing
+*
"incr x 1"}}
catch {unset x}
test incr-old-2.7 {incr errors} {
diff --git a/tests/incr.test b/tests/incr.test
index bdf0b76..07526c4 100644
--- a/tests/incr.test
+++ b/tests/incr.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: incr.test,v 1.10 2004/09/26 16:36:06 msofer Exp $
+# RCS: @(#) $Id: incr.test,v 1.11 2004/11/03 17:16:05 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -221,13 +221,14 @@ test incr-1.27 {TclCompileIncrCmd: runtime error, bad variable name} -body {
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
while *ing
"set"*}}
-test incr-1.28 {TclCompileIncrCmd: runtime error, readonly variable} {
+test incr-1.28 {TclCompileIncrCmd: runtime error, readonly variable} -body {
proc readonly args {error "variable is read-only"}
set x 123
trace var x w readonly
list [catch {incr x 1} msg] $msg $errorInfo
-} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only
+} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
while executing
+*
"incr x 1"}}
catch {unset x}
test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} {
@@ -478,14 +479,15 @@ test incr-2.27 {incr command (not compiled): runtime error, bad variable name} -
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
while *ing
"set"*}}
-test incr-2.28 {incr command (not compiled): runtime error, readonly variable} {
+test incr-2.28 {incr command (not compiled): runtime error, readonly variable} -body {
set z incr
proc readonly args {error "variable is read-only"}
set x 123
trace var x w readonly
list [catch {$z x 1} msg] $msg $errorInfo
-} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only
+} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
while executing
+*
"$z x 1"}}
catch {unset x}
test incr-2.29 {incr command (not compiled): runtime error, bad variable value} {
diff --git a/tests/set.test b/tests/set.test
index 47a90d7..ce1d31a 100644
--- a/tests/set.test
+++ b/tests/set.test
@@ -10,10 +10,10 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: set.test,v 1.8 2000/04/10 17:19:04 ericm Exp $
+# RCS: @(#) $Id: set.test,v 1.9 2004/11/03 17:16:05 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
@@ -247,13 +247,14 @@ test set-2.3 {set command: runtime error, errors in reading variables} {
set a(6) 44
list [catch {set a(18)} msg] $msg
} {1 {can't read "a(18)": no such element in array}}
-test set-2.4 {set command: runtime error, readonly variable} {
+test set-2.4 {set command: runtime error, readonly variable} -body {
proc readonly args {error "variable is read-only"}
set x 123
trace var x w readonly
list [catch {set x 1} msg] $msg $errorInfo
-} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only
+} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
while executing
+*
"set x 1"}}
test set-2.5 {set command: runtime error, basic array operations} {
list [catch {set a(other)} msg] $msg
@@ -492,14 +493,15 @@ test set-4.3 {uncompiled set command: runtime error, errors in reading variables
$z a(6) 44
list [catch {$z a(18)} msg] $msg
} {1 {can't read "a(18)": no such element in array}}
-test set-4.4 {uncompiled set command: runtime error, readonly variable} {
+test set-4.4 {uncompiled set command: runtime error, readonly variable} -body {
set z set
proc readonly args {error "variable is read-only"}
$z x 123
trace var x w readonly
list [catch {$z x 1} msg] $msg $errorInfo
-} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only
+} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
while executing
+*
"$z x 1"}}
test set-4.5 {uncompiled set command: runtime error, basic array operations} {
set z set
diff --git a/tests/trace.test b/tests/trace.test
index d236421..120c335 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -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: trace.test,v 1.34 2004/03/01 17:33:45 dgp Exp $
+# RCS: @(#) $Id: trace.test,v 1.35 2004/11/03 17:16:05 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -2197,6 +2197,21 @@ test trace-32.1 {
set result
} [list [list delete foo]]
+test trace-33.1 {527164: Keep -errorinfo of traces} {
+ unset -nocomplain x y
+ trace add variable x write {error foo;#}
+ trace add variable y write {set x 2;#}
+ list [catch {set y 1} msg opts] $msg [dict get $opts -errorinfo]
+} {1 {can't set "y": can't set "x": foo} {foo
+ while executing
+"error foo"
+ (write trace on "x")
+ invoked from within
+"set x 2"
+ (write trace on "y")
+ invoked from within
+"set y 1"}}
+
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
catch {rename foobar {}}
generated by cgit v0.12 at 2024-07-15 22:42:59 (GMT)