diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclListObj.c | 8 | ||||
| -rw-r--r-- | generic/tclTestObj.c | 102 | ||||
| -rw-r--r-- | tests/listObj.test | 26 |
4 files changed, 138 insertions, 4 deletions
@@ -1,3 +1,9 @@ +2010-03-18 Don Porter <dgp@users.sourceforge.net> + + * 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]. + 2010-03-12 Jan Nijtmans <nijtmans@users.sf.net> * win/makefile.vc Fix [Bug 2967340]: Static build failure diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 95e3f33..82ffa3d 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -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: tclListObj.c,v 1.49.2.2 2008/09/10 13:18:11 dkf Exp $ + * RCS: @(#) $Id: tclListObj.c,v 1.49.2.3 2010/03/18 20:38:43 dgp Exp $ */ #include "tclInt.h" @@ -832,7 +832,11 @@ Tcl_ListObjReplace( } if (count < 0) { count = 0; - } else if (numElems < first+count) { + } else if (numElems < first+count || first+count < 0) { + /* + * The 'first+count < 0' condition here guards agains integer + * overflow in determining 'first+count' + */ count = numElems - first; } diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index c0a4275..0326208 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.21.2.1 2009/03/30 17:47:30 dgp Exp $ + * RCS: @(#) $Id: tclTestObj.c,v 1.21.2.2 2010/03/18 20:38:43 dgp Exp $ */ #include "tclInt.h" @@ -48,6 +48,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, @@ -98,6 +100,8 @@ TclObjTest_Init( (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd, (ClientData) 0, NULL); + Tcl_CreateObjCommand(interp, "testlistobj", TestlistobjCmd, + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd, (ClientData) 0, NULL); @@ -776,6 +780,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 -- diff --git a/tests/listObj.test b/tests/listObj.test index a3c9f20..515592b 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -11,13 +11,15 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: listObj.test,v 1.8 2005/07/27 18:12:43 dgp Exp $ +# RCS: @(#) $Id: listObj.test,v 1.8.10.1 2010/03/18 20:38:43 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +testConstraint testobj [llength [info commands testobj]] + catch {unset x} test listobj-1.1 {Tcl_GetListObjType} emptyTest { # Test removed; tested an internal detail @@ -175,6 +177,28 @@ test listobj-9.1 {UpdateStringOfList} { string length [list foo\x00help] } 8 +test listobj-10.1 {Bug [2971669]} {*}{ + -constraints testobj + -setup { + testobj freeallvars + } + -body { + set result {} + lappend result \ + [testlistobj set 1 a b c d e] \ + [testlistobj replace 1 0x7fffffff 0x7fffffff f] \ + [testlistobj get 1] + } + -cleanup { + testobj freeallvars + } + -result {{a b c d e} {} {a b c d e f}} +} + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End:
\ No newline at end of file |