diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclIndexObj.c | 47 | ||||
| -rw-r--r-- | generic/tclTest.c | 45 | ||||
| -rw-r--r-- | tests/indexObj.test | 38 |
4 files changed, 106 insertions, 31 deletions
@@ -1,3 +1,10 @@ +2011-09-27 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclIndexObj.c (Tcl_ParseArgsObjv): [Bug 3413857]: Corrected + the memory management for the code parsing arguments when returning + "large" numbers of arguments. Also unbroke the TCL_ARGV_AUTO_REST + macro in passing. + 2011-09-26 Donal K. Fellows <dkf@users.sf.net> * generic/tclCmdAH.c (TclMakeFileCommandSafe): [Bug 3211758]: Also diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 6f378a4..8651542 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -1113,13 +1113,15 @@ Tcl_ParseArgsObjv( if (remObjv != NULL) { /* - * Then we should copy the name of the command (0th argument). + * Then we should copy the name of the command (0th argument). The + * upper bound on the number of elements is known, and (undocumented, + * but historically true) there should be a NULL argument after the + * last result. [Bug 3413857] */ nrem = 1; - leftovers = ckalloc((nrem + 1) * sizeof(Tcl_Obj *)); - leftovers[nrem-1] = objv[0]; - leftovers[nrem] = NULL; + leftovers = ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); + leftovers[0] = objv[0]; } else { nrem = 0; leftovers = NULL; @@ -1182,14 +1184,7 @@ Tcl_ParseArgsObjv( } dstIndex++; /* This argument is now handled */ - nrem++; - - /* - * Allocate nrem (+1 extra for NULL terminator) pointers. - */ - - leftovers = ckrealloc(leftovers, (nrem+1) * sizeof(Tcl_Obj *)); - leftovers[nrem-1] = curArg; + leftovers[nrem++] = curArg; continue; } @@ -1227,7 +1222,14 @@ Tcl_ParseArgsObjv( objc--; break; case TCL_ARGV_REST: - *((int *) infoPtr->dstPtr) = dstIndex; + /* + * Only store the point where we got to if it's not to be written + * to NULL, so that TCL_ARGV_AUTO_REST works. + */ + + if (infoPtr->dstPtr != NULL) { + *((int *) infoPtr->dstPtr) = dstIndex; + } goto argsDone; case TCL_ARGV_FLOAT: if (objc == 0) { @@ -1282,7 +1284,9 @@ Tcl_ParseArgsObjv( /* * If we broke out of the loop because of an OPT_REST argument, copy the - * remaining arguments down. + * remaining arguments down. Note that there is always at least one + * argument left over - the command name - so we always have a result if + * our caller is willing to receive it. [Bug 3413857] */ argsDone: @@ -1295,19 +1299,12 @@ Tcl_ParseArgsObjv( } if (objc > 0) { - leftovers = ckrealloc(leftovers, (nrem+objc+1) * sizeof(Tcl_Obj *)); - while (objc) { - leftovers[nrem] = objv[srcIndex]; - nrem++; - srcIndex++; - objc--; - } - } else if (leftovers != NULL) { - ckfree(leftovers); + memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *)); + nrem += objc; } leftovers[nrem] = NULL; - *objcPtr = nrem; - *remObjv = leftovers; + *objcPtr = nrem++; + *remObjv = ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *)); return TCL_OK; /* diff --git a/generic/tclTest.c b/generic/tclTest.c index 96dcb36..5b74663 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -311,6 +311,8 @@ static int TestpanicCmd(ClientData dummy, static int TestfinexitObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int TestparserObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -624,6 +626,7 @@ Tcltest_Init( NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, @@ -7082,6 +7085,48 @@ TestconcatobjCmd( } /* + *---------------------------------------------------------------------- + * + * TestparseargsCmd -- + * + * This procedure implements the "testparseargs" command. It is used to + * test that Tcl_ParseArgsObjv does indeed return the right number of + * arguments. In other words, that [Bug 3413857] was fixed properly. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestparseargsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Arguments. */ +{ + int count = objc, foo = 0; + Tcl_Obj **remObjv, *result[3]; + Tcl_ArgvInfo argTable[] = { + {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL}, + TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END + }; + + if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) { + return TCL_ERROR; + } + result[0] = Tcl_NewIntObj(foo); + result[1] = Tcl_NewIntObj(count); + result[2] = Tcl_NewListObj(count, remObjv); + Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/tests/indexObj.test b/tests/indexObj.test index 098aec0..479cc3b 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -1,20 +1,21 @@ # This file is a Tcl script to test out the the procedures in file -# tkIndexObj.c, which implement indexed table lookups. The tests here -# are organized in the standard fashion for Tcl tests. +# tkIndexObj.c, which implement indexed table lookups. The tests here are +# organized in the standard fashion for Tcl tests. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } testConstraint testindexobj [llength [info commands testindexobj]] - +testConstraint testparseargs [llength [info commands testparseargs]] + test indexObj-1.1 {exact match} testindexobj { testindexobj 1 1 xyz abc def xyz alm } {2} @@ -128,6 +129,31 @@ test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj { testgetindexfromobjstruct $x 1 } "wrong # args: should be \"testgetindexfromobjstruct c 1\"" +test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs { + testparseargs +} {0 1 testparseargs} +test indexObj-7.2 {Tcl_ParseArgsObjv} testparseargs { + testparseargs -bool +} {1 1 testparseargs} +test indexObj-7.3 {Tcl_ParseArgsObjv} testparseargs { + testparseargs -bool bar +} {1 2 {testparseargs bar}} +test indexObj-7.4 {Tcl_ParseArgsObjv} testparseargs { + testparseargs bar +} {0 2 {testparseargs bar}} +test indexObj-7.5 {Tcl_ParseArgsObjv} -constraints testparseargs -body { + testparseargs -help +} -returnCodes error -result {Command-specific options: + -bool: booltest + --: Marks the end of the options + -help: Print summary of command-line options and abort} +test indexObj-7.6 {Tcl_ParseArgsObjv} testparseargs { + testparseargs -- -bool -help +} {0 3 {testparseargs -bool -help}} +test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs { + testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0 +} {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0}} + # cleanup ::tcltest::cleanupTests return |