fix for [Bug 1008314]

5 files changed, 89 insertions, 13 deletions

diff --git a/ChangeLog b/ChangeLog
index 0090ae7..3cb7aed 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,4 +1,12 @@
-2004-03-31  Don Porter  <dgp@users.sourceforge.net>
+2004-07-23  Miguel Sofer <msofer@users.sf.net>
+
+	* doc/SetVar.3:
+	* generic/tclTest.c (TestseterrorcodeCmd):
+	* generic/tclVar.c (TclPtrSetVar):
+	* tests/result.test (result-4.*, result-5.*): [Bug 1008314]
+	detected and fixed by dgp.
+
+2004-08-13  Don Porter  <dgp@users.sourceforge.net>
 
 	* library/msgcat/msgcat.tcl:	Added checks to prevent [mclocale]
 	* tests/msgcat.test:	from registering filesystem paths to possibly
diff --git a/doc/SetVar.3 b/doc/SetVar.3
index 90b140b..c18c4c1 100644
--- a/doc/SetVar.3
+++ b/doc/SetVar.3
@@ -5,7 +5,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: SetVar.3,v 1.8 2003/07/18 16:56:41 dgp Exp $
+'\" RCS: @(#) $Id: SetVar.3,v 1.9 2004/08/16 14:11:16 msofer Exp $
 '\" 
 .so man.macros
 .TH Tcl_SetVar 3 8.1 Tcl "Tcl Library Procedures"
@@ -221,6 +221,9 @@ A separator space is appended before the new list element unless
 the list element is going to be the first element in a list or
 sublist (i.e. the variable's current value is empty, or contains
 the single character ``{'', or ends in `` }'').
+When appending, the original value of the variable must also be
+a valid list, so that the operation is the appending of a new
+list element onto a list.
 .PP
 \fBTcl_GetVar\fR and \fBTcl_GetVar2\fR
 return the current value of a variable.
diff --git a/generic/tclTest.c b/generic/tclTest.c
index fc0356f..96d18d9 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -14,7 +14,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclTest.c,v 1.82 2004/05/19 10:38:24 dkf Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.83 2004/08/16 14:11:16 msofer Exp $
  */
 
 #define TCL_TEST
@@ -319,6 +319,8 @@ static int		TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy,
 			    Tcl_Interp *interp, int argc, CONST char **argv));
 static int		TestsetCmd _ANSI_ARGS_((ClientData dummy,
 			    Tcl_Interp *interp, int argc, CONST char **argv));
+static int		TestseterrorcodeCmd _ANSI_ARGS_((ClientData dummy,
+			    Tcl_Interp *interp, int argc, CONST char **argv));
 static int		TestsetobjerrorcodeCmd _ANSI_ARGS_((
 			    ClientData dummy, Tcl_Interp *interp,
 			    int objc, Tcl_Obj *CONST objv[]));
@@ -670,6 +672,8 @@ Tcltest_Init(interp)
             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
     Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
             (ClientData) TCL_LEAVE_ERR_MSG, (Tcl_CmdDeleteProc *) NULL);
+    Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
+	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
     Tcl_CreateObjCommand(interp, "testsetobjerrorcode", 
 	    TestsetobjerrorcodeCmd, (ClientData) 0,
 	    (Tcl_CmdDeleteProc *) NULL);
@@ -3890,11 +3894,46 @@ TestupvarCmd(dummy, interp, argc, argv)
 /*
  *----------------------------------------------------------------------
  *
+ * TestseterrorcodeCmd --
+ *
+ *	This procedure implements the "testseterrorcodeCmd".
+ *	This tests up to five elements passed to the
+ *	Tcl_SetErrorCode command.
+ *
+ * Results:
+ *	A standard Tcl result. Always returns TCL_ERROR so that
+ *	the error code can be tested.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+static int
+TestseterrorcodeCmd(dummy, interp, argc, argv)
+    ClientData dummy;			/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    CONST char **argv;			/* Argument strings. */
+{
+    if (argc > 6) {
+	Tcl_SetResult(interp, "too many args", TCL_STATIC);
+	return TCL_ERROR;
+    }
+    Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
+	    argv[5], NULL);
+    return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TestsetobjerrorcodeCmd --
  *
  *	This procedure implements the "testsetobjerrorcodeCmd".
- *	This tests up to five elements passed to the
- *	Tcl_SetObjErrorCode command.
+ *	This tests the Tcl_SetObjErrorCode function.
  *
  * Results:
  *	A standard Tcl result. Always returns TCL_ERROR so that
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 4b69ce6..6c1a4e5 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclVar.c,v 1.87 2004/07/23 18:32:06 msofer Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.88 2004/08/16 14:11:31 msofer Exp $
  */
 
 #ifdef STDC_HEADERS
@@ -1566,7 +1566,7 @@ TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags)
     CONST char *part2;		/* If non-NULL, gives the name of an element
 				 * in the array part1. */
     Tcl_Obj *newValuePtr;	/* New value for variable. */
-    CONST int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
+    CONST int flags;		/* OR-ed combination of TCL_GLOBAL_ONLY,
 				 * and TCL_LEAVE_ERR_MSG bits. */
 {
     Interp *iPtr = (Interp *) interp;
@@ -1625,8 +1625,11 @@ TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags)
      * "copy on write".
      */
 
+    if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) {
+	TclSetVarUndefined(varPtr);
+    }
     oldValuePtr = varPtr->value.objPtr;
-    if (flags & TCL_APPEND_VALUE) {
+    if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) {
 	if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
 	    Tcl_DecrRefCount(oldValuePtr);     /* discard old value */
 	    varPtr->value.objPtr = NULL;
diff --git a/tests/result.test b/tests/result.test
index 8054b75..92f8d41 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -65,27 +65,50 @@ test result-3.2 {Tcl_DiscardInterpResult} {testsaveresult} {
     testsaveresult free {set x 42} 1
 } {42}
 
-test result-4.1 {Tcl_SetObjErrorCode - one arg} {testsaveresult} {
+::tcltest::testConstraint testsetobjerrorcode \
+	[expr {[info commands testsetobjerrorcode] != {}}]
+
+test result-4.1 {Tcl_SetObjErrorCode - one arg} {testsetobjerrorcode} {
     catch {testsetobjerrorcode 1}
     list [set errorCode]
 } {1}
-test result-4.2 {Tcl_SetObjErrorCode - two args} {testsaveresult} {
+test result-4.2 {Tcl_SetObjErrorCode - two args} {testsetobjerrorcode} {
     catch {testsetobjerrorcode 1 2}
     list [set errorCode]
 } {{1 2}}
-test result-4.3 {Tcl_SetObjErrorCode - three args} {testsaveresult} {
+test result-4.3 {Tcl_SetObjErrorCode - three args} {testsetobjerrorcode} {
     catch {testsetobjerrorcode 1 2 3}
     list [set errorCode]
 } {{1 2 3}}
-test result-4.4 {Tcl_SetObjErrorCode - four args} {testsaveresult} {
+test result-4.4 {Tcl_SetObjErrorCode - four args} {testsetobjerrorcode} {
     catch {testsetobjerrorcode 1 2 3 4}
     list [set errorCode]
 } {{1 2 3 4}}
-test result-4.5 {Tcl_SetObjErrorCode - five args} {testsaveresult} {
+test result-4.5 {Tcl_SetObjErrorCode - five args} {testsetobjerrorcode} {
     catch {testsetobjerrorcode 1 2 3 4 5}
     list [set errorCode]
 } {{1 2 3 4 5}}
 
+::tcltest::testConstraint testseterrorcode \
+	[expr {[info commands testseterrorcode] != {}}]
+
+test result-5.1 {Tcl_SetErrorCode - one arg} testseterrorcode {
+    catch {testseterrorcode 1}
+    set errorCode
+} 1
+test result-5.2 {Tcl_SetErrorCode - one arg, list quoting} testseterrorcode {
+    catch {testseterrorcode {a b}}
+    set errorCode
+} {{a b}}
+test result-5.3 {Tcl_SetErrorCode - one arg, list quoting} testseterrorcode {
+    catch {testseterrorcode \{}
+    llength $errorCode
+} 1
+test result-5.4 {Tcl_SetErrorCode - two args, list quoting} testseterrorcode {
+    catch {testseterrorcode {a b} c}
+    set errorCode
+} {{a b} c}
+
 # cleanup
 ::tcltest::cleanupTests
 return