summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog6
-rw-r--r--generic/tclListObj.c8
-rw-r--r--generic/tclTestObj.c102
-rw-r--r--tests/listObj.test26
4 files changed, 138 insertions, 4 deletions
diff --git a/ChangeLog b/ChangeLog
index af1664f..ec61fae 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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