Attachment "527164.patch" to
ticket [527164ffff]
added by
dgp
2004-11-04 00:12:11.
Index: generic/tclTrace.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTrace.c,v
retrieving revision 1.18
diff -u -r1.18 tclTrace.c
--- generic/tclTrace.c 25 Oct 2004 01:06:51 -0000 1.18
+++ generic/tclTrace.c 3 Nov 2004 17:03:47 -0000
@@ -2554,19 +2554,33 @@
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 @@
} 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);
Index: tests/incr-old.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/incr-old.test,v
retrieving revision 1.7
diff -u -r1.7 incr-old.test
--- tests/incr-old.test 27 Mar 2003 13:19:15 -0000 1.7
+++ tests/incr-old.test 3 Nov 2004 17:03:48 -0000
@@ -16,7 +16,7 @@
# RCS: @(#) $Id: incr-old.test,v 1.7 2003/03/27 13:19:15 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
@@ -65,13 +65,14 @@
(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} {
Index: tests/incr.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/incr.test,v
retrieving revision 1.10
diff -u -r1.10 incr.test
--- tests/incr.test 26 Sep 2004 16:36:06 -0000 1.10
+++ tests/incr.test 3 Nov 2004 17:03:48 -0000
@@ -221,13 +221,14 @@
} -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 @@
} -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} {
Index: tests/set.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/set.test,v
retrieving revision 1.8
diff -u -r1.8 set.test
--- tests/set.test 10 Apr 2000 17:19:04 -0000 1.8
+++ tests/set.test 3 Nov 2004 17:03:48 -0000
@@ -13,7 +13,7 @@
# RCS: @(#) $Id: set.test,v 1.8 2000/04/10 17:19:04 ericm Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
@@ -247,13 +247,14 @@
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 @@
$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
Index: tests/trace.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/trace.test,v
retrieving revision 1.34
diff -u -r1.34 trace.test
--- tests/trace.test 1 Mar 2004 17:33:45 -0000 1.34
+++ tests/trace.test 3 Nov 2004 17:03:48 -0000
@@ -2197,6 +2197,21 @@
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 {}}
