From eb5c3529d6f7ce0af6006fd19ef2053042141731 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 18 Mar 2010 20:34:47 +0000 Subject: * 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]. --- ChangeLog | 6 +++ generic/tclListObj.c | 8 +++- generic/tclTestObj.c | 102 ++++++++++++++++++++++++++++++++++++++++++++++++++- tests/listObj.test | 26 ++++++++++++- 4 files changed, 138 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 979c569..54f0135 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2010-03-18 Don Porter + + * 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-18 Donal K. Fellows * generic/tclCompCmdsSZ.c (IssueTryFinallyInstructions): diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 896dcd3..6745f62 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.59 2010/02/24 14:30:34 dkf Exp $ + * RCS: @(#) $Id: tclListObj.c,v 1.60 2010/03/18 20:34:48 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 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 -- diff --git a/tests/listObj.test b/tests/listObj.test index a3c9f20..2e8ae17 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.9 2010/03/18 20:34:48 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 -- cgit v0.12