* 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]

4 files changed, 36 insertions, 16 deletions

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 {}}