From f6daa6116e683fc15534f46a414da180d25bf7fa Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 3 Nov 2004 17:16:03 +0000 Subject: * 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] --- ChangeLog | 8 ++++++++ generic/tclTrace.c | 41 ++++++++++++++++++++++++++++++++++------- tests/incr-old.test | 9 +++++---- tests/incr.test | 12 +++++++----- tests/set.test | 14 ++++++++------ tests/trace.test | 17 ++++++++++++++++- 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 + + * 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 * 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 {}} -- cgit v0.12