merge updates from HEAD

4 files changed, 55 insertions, 4 deletions

diff --git a/ChangeLog b/ChangeLog
index 5eace44..deb652b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2007-11-03  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclTest.c (TestSetCmd2):
+	* generic/tclVar.c (TclObjLookupVarEx): 
+	* tests/set.test (set-5.1): fix error branch when array name looks
+	like array element (code not normally exercised). 
+	
 2007-11-01  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
 
 	* tools/tcltk-man2html.tcl (output-directive): Convert .DS/.DE pairs
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 8f6bb74..bc0492f 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.110.2.1 2007/06/27 22:44:48 dgp Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.110.2.2 2007/11/05 14:20:54 dgp Exp $
  */
 
 #define TCL_TEST
@@ -343,6 +343,8 @@ static int		TestsetassocdataCmd(ClientData dummy,
 			    Tcl_Interp *interp, int argc, const char **argv);
 static int		TestsetCmd(ClientData dummy,
 			    Tcl_Interp *interp, int argc, const char **argv);
+static int		Testset2Cmd(ClientData dummy,
+			    Tcl_Interp *interp, int argc, const char **argv);
 static int		TestseterrorcodeCmd(ClientData dummy,
 			    Tcl_Interp *interp, int argc, const char **argv);
 static int		TestsetobjerrorcodeCmd(
@@ -666,6 +668,8 @@ Tcltest_Init(
 	    (ClientData) 0, NULL);
     Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
 	    (ClientData) TCL_LEAVE_ERR_MSG, NULL);
+    Tcl_CreateCommand(interp, "testset2", Testset2Cmd,
+	    (ClientData) TCL_LEAVE_ERR_MSG, NULL);
     Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
 	    (ClientData) 0, NULL);
     Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
@@ -4812,6 +4816,38 @@ TestsetCmd(
 	return TCL_ERROR;
     }
 }
+static int
+Testset2Cmd(
+    ClientData data,		/* Additional flags for Get/SetVar2. */
+    register Tcl_Interp *interp,/* Current interpreter. */
+    int argc,			/* Number of arguments. */
+    const char **argv)		/* Argument strings. */
+{
+    int flags = PTR2INT(data);
+    const char *value;
+
+    if (argc == 3) {
+	Tcl_SetResult(interp, "before get", TCL_STATIC);
+	value = Tcl_GetVar2(interp, argv[1], argv[2], flags);
+	if (value == NULL) {
+	    return TCL_ERROR;
+	}
+	Tcl_AppendElement(interp, value);
+	return TCL_OK;
+    } else if (argc == 4) {
+	Tcl_SetResult(interp, "before set", TCL_STATIC);
+	value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags);
+	if (value == NULL) {
+	    return TCL_ERROR;
+	}
+	Tcl_AppendElement(interp, value);
+	return TCL_OK;
+    } else {
+	Tcl_AppendResult(interp, "wrong # args: should be \"",
+		argv[0], " varName elemName ?newValue?\"", NULL);
+	return TCL_ERROR;
+    }
+}
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclVar.c b/generic/tclVar.c
index a460f10..e5077cb 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -16,7 +16,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.135.2.8 2007/10/27 04:11:47 dgp Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.135.2.9 2007/11/05 14:20:57 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -597,7 +597,7 @@ TclObjLookupVarEx(
 
 		if (flags & TCL_LEAVE_ERR_MSG) {
 		    TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
-			    needArray, -1);
+			    noSuchVar, -1);
 		}
 		return NULL;
 	    }
@@ -631,6 +631,7 @@ TclObjLookupVarEx(
 			TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
 				needArray, -1);
 		    }
+		    return NULL;
 		}
 
 		/*
diff --git a/tests/set.test b/tests/set.test
index 3733e4c..07d8f01 100644
--- a/tests/set.test
+++ b/tests/set.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: set.test,v 1.11.4.1 2007/10/16 03:50:33 dgp Exp $
+# RCS: @(#) $Id: set.test,v 1.11.4.2 2007/11/05 14:20:57 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -514,6 +514,13 @@ test set-4.6 {set command: runtime error, basic array operations} {
     list [catch {$z a} msg] $msg
 } {1 {can't read "a": variable is array}}
 
+test set-5.1 {error on malformed array name} {
+    unset -nocomplain z
+    catch {testset2 z(a) b} msg
+    catch {testset2 z(b) a} msg1
+    list $msg $msg1
+} {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}}
+
 # cleanup
 catch {unset a}
 catch {unset b}