diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclTest.c | 38 | ||||
| -rw-r--r-- | generic/tclVar.c | 5 | ||||
| -rw-r--r-- | tests/set.test | 9 |
4 files changed, 55 insertions, 4 deletions
@@ -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 e7be33f..7785cc3 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.111 2007/06/27 18:21:52 dgp Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.112 2007/11/03 01:47:13 msofer 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 db3d090..56d57c3 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.153 2007/10/27 00:24:17 msofer Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.154 2007/11/03 01:47:13 msofer 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 3ac1560..0704436 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.12 2007/10/15 21:27:50 dgp Exp $ +# RCS: @(#) $Id: set.test,v 1.13 2007/11/03 01:47:13 msofer 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} |