Attachment "errorcode.patch" to
ticket [2383005fff]
added by
ferrieux
2010-03-19 05:44:50.
Index: generic/tclResult.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclResult.c,v
retrieving revision 1.57
diff -u -p -r1.57 tclResult.c
--- generic/tclResult.c 24 Feb 2010 10:45:04 -0000 1.57
+++ generic/tclResult.c 18 Mar 2010 22:42:16 -0000
@@ -1425,6 +1425,27 @@ TclMergeReturnOptions(
}
/*
+ * Check for bogus -errorcode value.
+ */
+
+ Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORCODE], &valuePtr);
+ if (valuePtr != NULL) {
+ int length;
+
+ if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) {
+ /*
+ * Value is not a list, which is illegal for -errorcode.
+ */
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "bad -errorcode value: "
+ "expected a list but got \"",
+ TclGetString(valuePtr), "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORCODE", NULL);
+ goto error;
+ }
+ }
+
+ /*
* Convert [return -code return -level X] to [return -code ok -level X+1]
*/
Index: tests/result.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/result.test,v
retrieving revision 1.15
diff -u -p -r1.15 result.test
--- tests/result.test 23 Apr 2008 15:44:37 -0000 1.15
+++ tests/result.test 18 Mar 2010 22:42:18 -0000
@@ -131,7 +131,10 @@ test result-6.2 {Bug 1649062} -setup {
} -cleanup {
rename foo {}
} -result {foo {} {}}
-
+test result-6.3 {Bug 2383005} {
+ catch {return -code error -errorcode {{}a} eek} m
+ set m
+} {bad -errorcode value: expected a list but got "{}a"}
# cleanup
cleanupTests
return
