Better error-message in case of errors related to setting a variable

9 files changed, 59 insertions, 74 deletions

diff --git a/ChangeLog b/ChangeLog
index b734896..63e4391 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2011-04-04  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* generic/tclCmdAH.c:  Better error-message in case of errors
+	* generic/tclCmdIL.c:  related to setting a variable. This fixes
+	* generic/tclDictObj.c: a warning: "Why make your own error
+	* generic/tclScan.c:   message? Why?"
+	* generic/tclTest.c:
+	* test/error.test:
+	* test/info.test:
+	* test/scan.test:
+
 2011-04-03  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclNamesp.c, generic/tclObj.c, generic/tclPathObj.c:
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 3edfa54..8b5f13d 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -345,10 +345,7 @@ CatchObjCmdCallback(
 
     if (objc >= 3) {
 	if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
-		Tcl_GetObjResult(interp), 0)) {
-	    Tcl_ResetResult(interp);
-	    Tcl_AppendResult(interp,
-		    "couldn't save command result in variable", NULL);
+		Tcl_GetObjResult(interp), TCL_LEAVE_ERR_MSG)) {
 	    return TCL_ERROR;
 	}
     }
@@ -356,11 +353,8 @@ CatchObjCmdCallback(
 	Tcl_Obj *options = Tcl_GetReturnOptions(interp, result);
 
 	if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL,
-		options, 0)) {
+		options, TCL_LEAVE_ERR_MSG)) {
 	    Tcl_DecrRefCount(options);
-	    Tcl_ResetResult(interp);
-	    Tcl_AppendResult(interp,
-		    "couldn't save return options in variable", NULL);
 	    return TCL_ERROR;
 	}
     }
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index b38ec9f..c42a54b 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -966,7 +966,7 @@ InfoDefaultCmd(
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
     Interp *iPtr = (Interp *) interp;
-    const char *procName, *argName, *varName;
+    const char *procName, *argName;
     Proc *procPtr;
     CompiledLocal *localPtr;
     Tcl_Obj *valueObjPtr;
@@ -993,18 +993,18 @@ InfoDefaultCmd(
 		&& (strcmp(argName, localPtr->name) == 0)) {
 	    if (localPtr->defValuePtr != NULL) {
 		valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
-			localPtr->defValuePtr, 0);
+			localPtr->defValuePtr, TCL_LEAVE_ERR_MSG);
 		if (valueObjPtr == NULL) {
-		    goto defStoreError;
+		    return TCL_ERROR;
 		}
 		Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
 	    } else {
 		Tcl_Obj *nullObjPtr = Tcl_NewObj();
 
 		valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
-			nullObjPtr, 0);
+			nullObjPtr, TCL_LEAVE_ERR_MSG);
 		if (valueObjPtr == NULL) {
-		    goto defStoreError;
+		    return TCL_ERROR;
 		}
 		Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
 	    }
@@ -1016,12 +1016,6 @@ InfoDefaultCmd(
 	    "\" doesn't have an argument \"", argName, "\"", NULL);
     Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL);
     return TCL_ERROR;
-
-  defStoreError:
-    varName = TclGetString(objv[3]);
-    Tcl_AppendResult(interp, "couldn't store default value in variable \"",
-	    varName, "\"", NULL);
-    return TCL_ERROR;
 }
 
 /*
@@ -1058,7 +1052,7 @@ InfoErrorStackCmd(
 	Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
 	return TCL_ERROR;
     }
-    
+
     target = interp;
     if (objc == 2) {
         target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
@@ -1069,7 +1063,7 @@ InfoErrorStackCmd(
 
     iPtr = (Interp *) target;
     Tcl_SetObjResult(interp, iPtr->errorStack);
-    
+
     return TCL_OK;
 }
 
@@ -1163,7 +1157,7 @@ InfoFrameCmd(
         CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
         CmdFrame *runPtr = iPtr->cmdFramePtr;
         CmdFrame *lastPtr = NULL;
-        
+
         topLevel += corPtr->caller.cmdFramePtr->level;
         while (runPtr && (runPtr != corPtr->caller.cmdFramePtr)) {
             lastPtr = runPtr;
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 3da91a3..508c2af 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -2456,18 +2456,12 @@ DictForNRCmd(
      */
 
     Tcl_IncrRefCount(valueObj);
-    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) {
-	Tcl_ResetResult(interp);
-	Tcl_AppendResult(interp, "couldn't set key variable: \"",
-		TclGetString(keyVarObj), "\"", NULL);
+    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
 	TclDecrRefCount(valueObj);
 	goto error;
     }
     TclDecrRefCount(valueObj);
-    if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) {
-	Tcl_ResetResult(interp);
-	Tcl_AppendResult(interp, "couldn't set value variable: \"",
-		TclGetString(valueVarObj), "\"", NULL);
+    if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
 	goto error;
     }
 
@@ -2540,19 +2534,13 @@ DictForLoopCallback(
      */
 
     Tcl_IncrRefCount(valueObj);
-    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) {
-	Tcl_ResetResult(interp);
-	Tcl_AppendResult(interp, "couldn't set key variable: \"",
-		TclGetString(keyVarObj), "\"", NULL);
+    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
 	TclDecrRefCount(valueObj);
 	result = TCL_ERROR;
 	goto done;
     }
     TclDecrRefCount(valueObj);
-    if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) {
-	Tcl_ResetResult(interp);
-	Tcl_AppendResult(interp, "couldn't set value variable: \"",
-		TclGetString(valueVarObj), "\"", NULL);
+    if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
 	result = TCL_ERROR;
 	goto done;
     }
diff --git a/generic/tclScan.c b/generic/tclScan.c
index 68b8d21..06e66e4 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -1001,10 +1001,10 @@ Tcl_ScanObjCmd(
 		continue;
 	    }
 	    result++;
-#warning Why make your own error message? Why?
-	    if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) {
-		Tcl_AppendResult(interp, "couldn't set variable \"",
-			TclGetString(objv[i+3]), "\"", NULL);
+	    /* In case of multiple errors in setting variables, just report
+	     * the first one. */
+	    if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i],
+		    (code == TCL_OK) ? TCL_LEAVE_ERR_MSG : 0) == NULL) {
 		code = TCL_ERROR;
 	    }
 	    Tcl_DecrRefCount(objs[i]);
diff --git a/generic/tclTest.c b/generic/tclTest.c
index b757185..bac0c7f 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -3939,10 +3939,8 @@ TestregexpObjCmd(
 			info.matches[ii].end - 1);
 	    }
 	}
-	valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0);
+	valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, TCL_LEAVE_ERR_MSG);
 	if (valuePtr == NULL) {
-	    Tcl_AppendResult(interp, "couldn't set variable \"",
-		    Tcl_GetString(varPtr), "\"", NULL);
 	    return TCL_ERROR;
 	}
     }
diff --git a/tests/error.test b/tests/error.test
index c34ccb0..97bcc0a 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -138,7 +138,7 @@ test error-3.3 {errors in catch command} {
     catch {unset a}
     set a(0) 22
     list [catch {catch {format 44} a} msg] $msg
-} {1 {couldn't save command result in variable}}
+} {1 {can't set "a": variable is array}}
 catch {unset a}
 
 # More tests related to errorInfo and errorCode
@@ -417,7 +417,7 @@ test error-12.4 {try with result/opts variable assignment in on handler} {
 } {bar,FOO}
 test error-12.5 {try with result/opts variable assignment in on handler, vars remain in scope} {
     try { throw FOO bar } on error {res opts} { list d e f }
-    set r "$res,[dict get $opts -errorcode]"  
+    set r "$res,[dict get $opts -errorcode]"
 } {bar,FOO}
 test error-12.6 {try result is propagated if no matching handler} {
     try { list a b c } on error {} { list d e f }
@@ -459,7 +459,7 @@ test error-13.8 {try with multiple handlers and finally (ok)} {
     try list on error {} {} trap {} {} {} finally {}
 } {}
 test error-13.9 {last handler body can't be a fallthrough #1} -body {
-    try list on error {} {} on break {} - 
+    try list on error {} {} on break {} -
 } -returnCodes error -result {last non-finally clause must not have a body of "-"}
 test error-13.10 {last handler body can't be a fallthrough #2} -body {
     try list on error {} {} on break {} - finally { list d e f }
@@ -471,7 +471,7 @@ test error-14.1 {try with multiple handlers (only one matches) #1} {
     try { throw FOO bar } on ok {} { list a b c } trap FOO {} { list d e f }
 } {d e f}
 test error-14.2 {try with multiple handlers (only one matches) #2} {
-    try { throw FOO bar } trap FOO {} { list d e f } on ok {} { list a b c } 
+    try { throw FOO bar } trap FOO {} { list d e f } on ok {} { list a b c }
 } {d e f}
 test error-14.3 {try with multiple handlers (only one matches) #3} {
     try {
@@ -482,7 +482,7 @@ test error-14.3 {try with multiple handlers (only one matches) #3} {
 	list d e f
     } on ok {} {
 	list a b c
-    } 
+    }
 } {d e f}
 test error-14.4 {try with multiple matching handlers (only the first in left-to-right order runs) #1} {
     try { throw FOO bar } on error {} { list a b c } trap FOO {} { list d e f }
@@ -593,16 +593,16 @@ test error-16.6 {try with variable assignment and propagation #1} {
     catch {
 	try { throw FOO bar } trap FOO {em} { throw BAR baz }
     }
-    set em  
+    set em
 } {bar}
 test error-16.7 {try with variable assignment and propagation #2} {
     catch {
 	try { throw FOO bar } trap FOO {em opts} { throw BAR baz }
     }
-    list $em [dict get $opts -errorcode]  
+    list $em [dict get $opts -errorcode]
 } {bar FOO}
 test error-16.8 {exception chaining (try=ok, handler=error)} {
-    #FIXME is the intent of this test correct?  
+    #FIXME is the intent of this test correct?
     catch {
 	try { list a b c } on ok {em opts} { throw BAR baz }
     } tryem tryopts
@@ -686,7 +686,7 @@ test error-17.11 {successful finally doesn't affect variable assignment or propa
     catch {
 	try { throw FOO bar } trap FOO {em opts} { throw BAR baz } finally { list d e f }
     }
-    list $em [dict get $opts -errorcode]  
+    list $em [dict get $opts -errorcode]
 } {bar FOO}
 
 # try tests - propagation (exceptions in finally, exception chaining)
@@ -707,11 +707,11 @@ test error-18.5 {exception in finally doesn't affect variable assignment} {
     catch {
 	try { throw FOO bar } trap FOO {em opts} { throw BAR baz } finally { throw BAZ zing }
     }
-    list $em [dict get $opts -errorcode]  
+    list $em [dict get $opts -errorcode]
 } {bar FOO}
 test error-18.6 {exception chaining in finally (try=ok)} {
     catch {
-	list a b c 
+	list a b c
     } em expopts
     catch {
 	try { list a b c } finally { throw BAR foo }
@@ -782,14 +782,14 @@ test error-19.1 {try with fallthrough body #1} {
 } {1}
 test error-19.2 {try with fallthrough body #2} {
     set RES {}
-    try { 
-	throw FOO bar 
+    try {
+	throw FOO bar
     } trap BAR {} {
     } trap FOO {} - trap {} {} {
 	set RES foo
     } on error {} {
 	set RES err
-    }  
+    }
     set RES
 } {foo}
 test error-19.3 {try with cascade fallthrough} {
@@ -805,22 +805,22 @@ test error-19.4 {multiple unrelated fallthroughs #1} {
     set RES {}
     try {
 	throw FOO bar
-    } trap FOO {} - trap BAR {} { 
+    } trap FOO {} - trap BAR {} {
 	set RES foo
     } trap {} {} - on error {} {
 	set RES err
-    } 
+    }
     set RES
 } {foo}
 test error-19.5 {multiple unrelated fallthroughs #2} {
     set RES {}
     try {
 	throw BAZ zing
-    } trap FOO {} - trap BAR {} { 
+    } trap FOO {} - trap BAR {} {
 	set RES foo
     } trap {} {} - on error {} {
 	set RES err
-    } 
+    }
     set RES
 } {err}
 proc addmsg msg {
@@ -1054,7 +1054,7 @@ namespace delete ::tcl::test::error
 # cleanup
 catch {rename p ""}
 ::tcltest::cleanupTests
-return 
+return
 
 # Local Variables:
 # mode: tcl
diff --git a/tests/info.test b/tests/info.test
index 9977054..3323281 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -215,14 +215,14 @@ test info-6.9 {info default option} -returnCodes error -setup {
     set a(0) 88
     proc t1 {a b} {}
     info default t1 a a
-} -returnCodes error -result {couldn't store default value in variable "a"}
+} -returnCodes error -result {can't set "a": variable is array}
 test info-6.10 {info default option} -setup {
     catch {unset a}
 } -cleanup {unset a} -body {
     set a(0) 88
     proc t1 {{a 18} b} {}
     info default t1 a a
-} -returnCodes error -result {couldn't store default value in variable "a"}
+} -returnCodes error -result {can't set "a": variable is array}
 test info-6.11 {info default option} {
     catch {namespace delete test_ns_info2}
     namespace eval test_ns_info2 {
@@ -1826,7 +1826,7 @@ test info-30.46 {TIP 280 for compiled [subst]} {
 } YES
 test info-30.47 {TIP 280 for compiled [subst]} {
     unset -nocomplain a
-    set a(\n1831) YES;  set a(\n1830) 1830; set a(\n1832) 1832 
+    set a(\n1831) YES;  set a(\n1830) 1830; set a(\n1832) 1832
     subst {$a(
 [dict get [info frame 0] line])} ; # 1831
 } YES
diff --git a/tests/scan.test b/tests/scan.test
index 6e1ccb0..84f22b4 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -328,7 +328,7 @@ test scan-4.60 {Tcl_ScanObjCmd, set errors} {
 	    $msg $x $y]
     unset z
     set result
-} {1 {couldn't set variable "z"} abc ghi}
+} {1 {can't set "z": variable is array} abc ghi}
 test scan-4.61 {Tcl_ScanObjCmd, set errors} {
     set x {}
     catch {unset y}; array set y {}
@@ -338,7 +338,7 @@ test scan-4.61 {Tcl_ScanObjCmd, set errors} {
     unset y
     unset z
     set result
-} {1 {couldn't set variable "z"couldn't set variable "y"} abc}
+} {1 {can't set "z": variable is array} abc}
 
 # procedure that returns the range of integers
 
@@ -545,27 +545,27 @@ test scan-8.12 {error conditions} {
     catch {unset a}
     set a(0) 44
     list [catch {scan 44 %d a} msg] $msg
-} {1 {couldn't set variable "a"}}
+} {1 {can't set "a": variable is array}}
 test scan-8.13 {error conditions} {
     catch {unset a}
     set a(0) 44
     list [catch {scan 44 %c a} msg] $msg
-} {1 {couldn't set variable "a"}}
+} {1 {can't set "a": variable is array}}
 test scan-8.14 {error conditions} {
     catch {unset a}
     set a(0) 44
     list [catch {scan 44 %s a} msg] $msg
-} {1 {couldn't set variable "a"}}
+} {1 {can't set "a": variable is array}}
 test scan-8.15 {error conditions} {
     catch {unset a}
     set a(0) 44
     list [catch {scan 44 %f a} msg] $msg
-} {1 {couldn't set variable "a"}}
+} {1 {can't set "a": variable is array}}
 test scan-8.16 {error conditions} {
     catch {unset a}
     set a(0) 44
     list [catch {scan 44 %f a} msg] $msg
-} {1 {couldn't set variable "a"}}
+} {1 {can't set "a": variable is array}}
 catch {unset a}
 test scan-8.17 {error conditions} {
     list [catch {scan 44 %2c a} msg] $msg