diff options
author | dgp <dgp@noemail.net> | 2010-03-18 20:34:46 (GMT) |
---|---|---|
committer | dgp <dgp@noemail.net> | 2010-03-18 20:34:46 (GMT) |
commit | 404f39c083d2ab8158639644cc0f15223c4f4c75 (patch) | |
tree | 3e3228f8c83eb5503e48c4498d346f0f3a536d98 /generic/tclTestObj.c | |
parent | 76c858b5b2fe7af66c6a64648a9c5c63d316999d (diff) | |
download | tcl-404f39c083d2ab8158639644cc0f15223c4f4c75.zip tcl-404f39c083d2ab8158639644cc0f15223c4f4c75.tar.gz tcl-404f39c083d2ab8158639644cc0f15223c4f4c75.tar.bz2 |
* generic/tclListObj.c: Prevent in overflow trouble in [lreplace]
* generic/tclTestObj.c: operations. Thanks to kbk for fix and test.
* tests/listObj.test: [Bug 2971669].
FossilOrigin-Name: d368f281354e8c4a363f1407f7e546a68b14c8cb
Diffstat (limited to 'generic/tclTestObj.c')
-rw-r--r-- | generic/tclTestObj.c | 102 |
1 files changed, 101 insertions, 1 deletions
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 1b33412..89f42a6 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTestObj.c,v 1.37 2010/02/25 22:20:10 nijtmans Exp $ + * RCS: @(#) $Id: tclTestObj.c,v 1.38 2010/03/18 20:34:48 dgp Exp $ */ #ifndef USE_TCL_STUBS @@ -50,6 +50,8 @@ static int TestindexobjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestintobjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestlistobjCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int TestobjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp, @@ -100,6 +102,8 @@ TclObjTest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testlistobj", TestlistobjCmd, + NULL, NULL); Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd, NULL, NULL); @@ -777,6 +781,102 @@ TestintobjCmd( } /* + *----------------------------------------------------------------------------- + * + * TestlistobjCmd -- + * + * This function implements the 'testlistobj' command. It is used to + * test a few possible corner cases in list object manipulation from + * C code that cannot occur at the Tcl level. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * Creates, manipulates and frees list objects. + * + *----------------------------------------------------------------------------- + */ + +static int +TestlistobjCmd( + ClientData clientData, /* Not used */ + Tcl_Interp *interp, /* Tcl interpreter */ + int objc, /* Number of arguments */ + Tcl_Obj *const objv[]) /* Argument objects */ +{ + /* Subcommands supported by this command */ + const char* subcommands[] = { + "set", + "get", + "replace" + }; + enum listobjCmdIndex { + LISTOBJ_SET, + LISTOBJ_GET, + LISTOBJ_REPLACE + }; + + const char* index; /* Argument giving the variable number */ + int varIndex; /* Variable number converted to binary */ + int cmdIndex; /* Ordinal number of the subcommand */ + int first; /* First index in the list */ + int count; /* Count of elements in a list */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?"); + return TCL_ERROR; + } + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command", + 0, &cmdIndex) != TCL_OK) { + return TCL_ERROR; + } + switch(cmdIndex) { + case LISTOBJ_SET: + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3); + } else { + SetVarToObj(varIndex, Tcl_NewListObj(objc-3, objv+3)); + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + break; + + case LISTOBJ_GET: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + break; + + case LISTOBJ_REPLACE: + if (objc < 5) { + Tcl_WrongNumArgs(interp, 2, objv, + "varIndex start count ?element...?"); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK + || Tcl_GetIntFromObj(interp, objv[4], &count) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_IsShared(varPtr[varIndex])) { + SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + } + Tcl_ResetResult(interp); + return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count, + objc-5, objv+5); + } + return TCL_OK; +} + +/* *---------------------------------------------------------------------- * * TestobjCmd -- |