From 0a7049c4674056ec95788074fd9275355f9e1b7f Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 5 Nov 2007 14:20:51 +0000 Subject: merge updates from HEAD --- ChangeLog | 7 +++++++ generic/tclTest.c | 38 +++++++++++++++++++++++++++++++++++++- generic/tclVar.c | 5 +++-- tests/set.test | 9 ++++++++- 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 + + * 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 * 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} -- cgit v0.12