* 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].

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