Add memory leak/refcount tests for lists, spans and lseq

2 files changed, 284 insertions, 107 deletions

diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index a03a60a..93af3c0 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -841,6 +841,35 @@ TestintobjCmd(
  *	test a few possible corner cases in list object manipulation from
  *	C code that cannot occur at the Tcl level.
  *
+ *      Following new commands are added for 8.7 as regression tests for
+ *      memory leaks and use-after-free. Unlike 8.6, 8.7 has multiple internal
+ *      representations for lists.  It has to be ensured that corresponding
+ *      implementations obey the invariants of the C list API. The script
+ *      level tests do not suffice as Tcl list commands do not execute
+ *      the same exact code path as the exported C API.
+ *
+ *      Note these new commands are only useful when Tcl is compiled with 
+ *      TCL_MEM_DEBUG defined.
+ *
+ *	indexmemcheck - loops calling Tcl_ListObjIndex on each element. This
+ *	is to test that abstract lists returning elements do not depend
+ *	on caller to free them. The test case should check allocated counts
+ *      with the following sequence:
+ *            set before <get memory counts>
+ *            testobj set VARINDEX [list a b c] (or lseq etc.)
+ *            testlistobj indexnoop VARINDEX
+ *            testobj unset VARINDEX
+ *            set after <get memory counts>
+ *      after calling this command AND freeing the passed list. The targeted
+ *      bug is if Tcl_LOI returns a ephemeral Tcl_Obj with no other reference
+ *      resulting in a memory leak. Conversely, the command also checks
+ *      that the Tcl_Obj returned by Tcl_LOI does not have a zero reference
+ *      count since it is supposed to have at least one reference held
+ *      by the list implementation. Returns a message in interp otherwise.
+ *
+ *      getelementsmemcheck - as above but for Tcl_ListObjGetElements
+
+ *
  * Results:
  *	A standard Tcl object result.
  *
@@ -861,25 +890,36 @@ TestlistobjCmd(
     const char* subcommands[] = {
 	"set",
 	"get",
-	"replace"
+	"replace",
+	"indexmemcheck",
+	"getelementsmemcheck",
+	NULL
     };
     enum listobjCmdIndex {
 	LISTOBJ_SET,
 	LISTOBJ_GET,
-	LISTOBJ_REPLACE
+	LISTOBJ_REPLACE,
+	LISTOBJ_INDEXMEMCHECK,
+	LISTOBJ_GETELEMENTSMEMCHECK,
     } cmdIndex;
 
     size_t varIndex;		/* Variable number converted to binary */
     Tcl_WideInt first;			/* First index in the list */
     Tcl_WideInt count;			/* Count of elements in a list */
     Tcl_Obj **varPtr;
+    int i;
+#if TCL_VERSION_MAJOR < 9
+    int len;
+#else
+    size_t len;
+#endif
 
     if (objc < 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?");
 	return TCL_ERROR;
     }
     varPtr = GetVarPtr(interp);
-	if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
+    if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
 	return TCL_ERROR;
     }
     if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command",
@@ -923,6 +963,58 @@ TestlistobjCmd(
 	Tcl_ResetResult(interp);
 	return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count,
 				  objc-5, objv+5);
+
+    case LISTOBJ_INDEXMEMCHECK:
+	if (objc != 3) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
+	    return TCL_ERROR;
+	}
+	if (CheckIfVarUnset(interp, varPtr, varIndex)) {
+	    return TCL_ERROR;
+	}
+	if (Tcl_ListObjLength(interp, varPtr[varIndex], &len) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	for (i = 0; i < len; ++i) {
+	    Tcl_Obj *objP;
+	    if (Tcl_ListObjIndex(interp, varPtr[varIndex], i, &objP)
+		!= TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    if (objP->refCount <= 0) {
+		Tcl_SetResult(
+		    interp,
+		    "Tcl_ListObjIndex returned object with ref count <= 0",
+		    TCL_STATIC);
+		/* Keep looping since we are also looping for leaks */
+	    }
+	}
+	break;
+
+    case LISTOBJ_GETELEMENTSMEMCHECK:
+	if (objc != 3) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
+	    return TCL_ERROR;
+	}
+	if (CheckIfVarUnset(interp, varPtr, varIndex)) {
+	    return TCL_ERROR;
+	} else {
+	    Tcl_Obj **elems;
+	    if (Tcl_ListObjGetElements(interp, varPtr[varIndex], &len, &elems)
+		!= TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    for (i = 0; i < len; ++i) {
+		if (elems[i]->refCount <= 0) {
+		    Tcl_SetResult(
+			interp,
+			"Tcl_ListObjGetElements element has ref count <= 0",
+			TCL_STATIC);
+		    break;
+		}
+	    }
+	}
+	break;
     }
     return TCL_OK;
 }
@@ -953,9 +1045,21 @@ TestobjCmd(
 {
     size_t varIndex, destIndex;
     int i;
-    const char *subCmd;
     const Tcl_ObjType *targetType;
     Tcl_Obj **varPtr;
+    const char *subcommands[] = {
+	"freeallvars", "bug3598580", "types",
+	"objtype", "newobj", "set",
+	"assign", "convert", "duplicate",
+	"invalidateStringRep", "refcount", "type",
+	NULL
+    };
+    enum testobjCmdIndex {
+	TESTOBJ_FREEALLVARS, TESTOBJ_BUG3598580, TESTOBJ_TYPES,
+	TESTOBJ_OBJTYPE, TESTOBJ_NEWOBJ, TESTOBJ_SET,
+	TESTOBJ_ASSIGN, TESTOBJ_CONVERT, TESTOBJ_DUPLICATE,
+	TESTOBJ_INVALIDATESTRINGREP, TESTOBJ_REFCOUNT, TESTOBJ_TYPE,
+    } cmdIndex;
 
     if (objc < 2) {
 	wrongNumArgs:
@@ -964,142 +1068,159 @@ TestobjCmd(
     }
 
     varPtr = GetVarPtr(interp);
-    subCmd = Tcl_GetString(objv[1]);
-    if (strcmp(subCmd, "assign") == 0) {
-	if (objc != 4) {
+    if (Tcl_GetIndexFromObj(
+	    interp, objv[1], subcommands, "command", 0, &cmdIndex)
+	!= TCL_OK) {
+	return TCL_ERROR;
+    }
+    switch (cmdIndex) {
+    case TESTOBJ_FREEALLVARS:
+	if (objc != 2) {
 	    goto wrongNumArgs;
 	}
-	if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
-	    return TCL_ERROR;
-	}
-	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
-	    return TCL_ERROR;
+	for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {
+	    if (varPtr[i] != NULL) {
+		Tcl_DecrRefCount(varPtr[i]);
+		varPtr[i] = NULL;
+	    }
 	}
-	if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) {
-	    return TCL_ERROR;
+	return TCL_OK;
+    case TESTOBJ_BUG3598580:
+	if (objc != 2) {
+	    goto wrongNumArgs;
+	} else {
+	    Tcl_Obj *listObjPtr, *elemObjPtr;
+	    elemObjPtr = Tcl_NewWideIntObj(123);
+	    listObjPtr = Tcl_NewListObj(1, &elemObjPtr);
+	    /* Replace the single list element through itself, nonsense but
+	     * legal. */
+	    Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr);
+	    Tcl_SetObjResult(interp, listObjPtr);
 	}
-	SetVarToObj(varPtr, destIndex, varPtr[varIndex]);
-	Tcl_SetObjResult(interp, varPtr[destIndex]);
-    } else if (strcmp(subCmd, "bug3598580") == 0) {
-	Tcl_Obj *listObjPtr, *elemObjPtr;
+	return TCL_OK;
+    case TESTOBJ_TYPES:
 	if (objc != 2) {
 	    goto wrongNumArgs;
+	} else {
+	    Tcl_Obj *typesObj = Tcl_NewListObj(0, NULL);
+	    Tcl_AppendAllObjTypes(interp, typesObj);
+	    Tcl_SetObjResult(interp, typesObj);
 	}
-	elemObjPtr = Tcl_NewWideIntObj(123);
-	listObjPtr = Tcl_NewListObj(1, &elemObjPtr);
-	/* Replace the single list element through itself, nonsense but legal. */
-	Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr);
-	Tcl_SetObjResult(interp, listObjPtr);
 	return TCL_OK;
-    } else if (strcmp(subCmd, "convert") == 0) {
+    case TESTOBJ_OBJTYPE:
+	/*
+	 * Return an object containing the name of the argument's type of
+	 * internal rep. If none exists, return "none".
+	 */
 
-	if (objc != 4) {
+	if (objc != 3) {
 	    goto wrongNumArgs;
+	} else {
+	    const char *typeName;
+
+	    if (objv[2]->typePtr == NULL) {
+		Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
+	    }
+	    else {
+		typeName = objv[2]->typePtr->name;
+		if (!strcmp(typeName, "utf32string"))
+		    typeName = "string";
+#ifndef TCL_WIDE_INT_IS_LONG
+	    else if (!strcmp(typeName, "wideInt")) typeName = "int";
+#endif
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
+	    }
 	}
-	if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
-	    return TCL_ERROR;
-	}
-	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
-	    return TCL_ERROR;
-	}
-	if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) {
-	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
-		    "no type ", Tcl_GetString(objv[3]), " found", NULL);
-	    return TCL_ERROR;
+	return TCL_OK;
+    case TESTOBJ_NEWOBJ:
+	if (objc != 3) {
+	    goto wrongNumArgs;
 	}
-	if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
-		!= TCL_OK) {
+	if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
+	SetVarToObj(varPtr, varIndex, Tcl_NewObj());
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
-    } else if (strcmp(subCmd, "duplicate") == 0) {
+	return TCL_OK;
+    case TESTOBJ_SET:
 	if (objc != 4) {
 	    goto wrongNumArgs;
 	}
 	if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
-	    return TCL_ERROR;
+	SetVarToObj(varPtr, varIndex, objv[3]);
+	return TCL_OK;
+
+    default:
+	break;
+    }
+
+    /* All further commands expect an occupied varindex argument */
+    if (objc < 3) {
+	goto wrongNumArgs;
+    }
+
+    if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    if (CheckIfVarUnset(interp, varPtr, varIndex)) {
+	return TCL_ERROR;
+    }
+
+    switch (cmdIndex) {
+    case TESTOBJ_ASSIGN:
+	if (objc != 4) {
+	    goto wrongNumArgs;
 	}
 	if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+	SetVarToObj(varPtr, destIndex, varPtr[varIndex]);
 	Tcl_SetObjResult(interp, varPtr[destIndex]);
-    } else if (strcmp(subCmd, "freeallvars") == 0) {
-	if (objc != 2) {
-	    goto wrongNumArgs;
-	}
-	for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {
-	    if (varPtr[i] != NULL) {
-		Tcl_DecrRefCount(varPtr[i]);
-		varPtr[i] = NULL;
-	    }
-	}
-    } else if (strcmp(subCmd, "invalidateStringRep") == 0) {
-	if (objc != 3) {
+	break;
+    case TESTOBJ_CONVERT:
+	if (objc != 4) {
 	    goto wrongNumArgs;
 	}
-	if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
+	if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) {
+	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+		    "no type ", Tcl_GetString(objv[3]), " found", NULL);
 	    return TCL_ERROR;
 	}
-	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+	if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
+		!= TCL_OK) {
 	    return TCL_ERROR;
 	}
-	Tcl_InvalidateStringRep(varPtr[varIndex]);
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
-    } else if (strcmp(subCmd, "newobj") == 0) {
-	if (objc != 3) {
+	break;
+    case TESTOBJ_DUPLICATE:
+	if (objc != 4) {
 	    goto wrongNumArgs;
 	}
-	if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
+	if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	SetVarToObj(varPtr, varIndex, Tcl_NewObj());
-	Tcl_SetObjResult(interp, varPtr[varIndex]);
-    } else if (strcmp(subCmd, "objtype") == 0) {
-	const char *typeName;
-
-	/*
-	 * Return an object containing the name of the argument's type of
-	 * internal rep. If none exists, return "none".
-	 */
-
+	SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+	Tcl_SetObjResult(interp, varPtr[destIndex]);
+	break;
+    case TESTOBJ_INVALIDATESTRINGREP:
 	if (objc != 3) {
 	    goto wrongNumArgs;
 	}
-	if (objv[2]->typePtr == NULL) {
-	    Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
-	} else {
-	    typeName = objv[2]->typePtr->name;
-	    if (!strcmp(typeName, "utf32string")) typeName = "string";
-#ifndef TCL_WIDE_INT_IS_LONG
-	    else if (!strcmp(typeName, "wideInt")) typeName = "int";
-#endif
-	    Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
-	}
-    } else if (strcmp(subCmd, "refcount") == 0) {
+	Tcl_InvalidateStringRep(varPtr[varIndex]);
+	Tcl_SetObjResult(interp, varPtr[varIndex]);
+	break;
+    case TESTOBJ_REFCOUNT:
 	if (objc != 3) {
 	    goto wrongNumArgs;
 	}
-	if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
-	    return TCL_ERROR;
-	}
-	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
-	    return TCL_ERROR;
-	}
 	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount));
-    } else if (strcmp(subCmd, "type") == 0) {
+	break;
+    case TESTOBJ_TYPE:
 	if (objc != 3) {
 	    goto wrongNumArgs;
 	}
-	if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
-	    return TCL_ERROR;
-	}
-	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
-	    return TCL_ERROR;
-	}
 	if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
 	    Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
 #ifndef TCL_WIDE_INT_IS_LONG
@@ -1111,21 +1232,9 @@ TestobjCmd(
 	    Tcl_AppendToObj(Tcl_GetObjResult(interp),
 		    varPtr[varIndex]->typePtr->name, -1);
 	}
-    } else if (strcmp(subCmd, "types") == 0) {
-	if (objc != 2) {
-	    goto wrongNumArgs;
-	}
-	if (Tcl_AppendAllObjTypes(interp,
-		Tcl_GetObjResult(interp)) != TCL_OK) {
-	    return TCL_ERROR;
-	}
-    } else {
-	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
-		"bad option \"", Tcl_GetString(objv[1]),
-		"\": must be assign, convert, duplicate, freeallvars, "
-		"newobj, objcount, objtype, refcount, type, or types", NULL);
-	return TCL_ERROR;
+	break;
     }
+
     return TCL_OK;
 }
 
diff --git a/tests/listObj.test b/tests/listObj.test
index 0b64635..0f43648 100644
--- a/tests/listObj.test
+++ b/tests/listObj.test
@@ -20,6 +20,7 @@ if {"::tcltest" ni [namespace children]} {
 catch [list package require -exact tcl::test [info patchlevel]]
 
 testConstraint testobj [llength [info commands testobj]]
+testConstraint memory [llength [info commands memory]]
 
 catch {unset x}
 test listobj-1.1 {Tcl_GetListObjType} emptyTest {
@@ -210,6 +211,73 @@ test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj
     testobj bug3598580
 } 123
 
+# Stolen from dict.test
+proc listobjmemcheck script {
+    set end [lindex [split [memory info] \n] 3 3]
+    for {set i 0} {$i < 5} {incr i} {
+        uplevel 1 $script
+        set tmp $end
+        set end [lindex [split [memory info] \n] 3 3]
+    }
+    expr {$end - $tmp}
+}
+
+test listobj-12.1 {Tcl_ListObjIndex memory leaks for native lists} -constraints {
+    testobj memory
+} -body {
+    list [listobjmemcheck {
+        testobj set 1 [lrepeat 1000 x]
+        set errorMessage [testlistobj indexmemcheck 1]
+        testobj freeallvars
+    }] $errorMessage
+} -result {0 {}}
+test listobj-12.2 {Tcl_ListObjIndex memory leaks for native lists with spans} -constraints {
+    testobj memory
+} -body {
+    list [listobjmemcheck {
+        testobj set 1 [testlistrep new 1000 100 100]
+        set errorMessage [testlistobj indexmemcheck 1]
+        testobj freeallvars
+    }] $errorMessage
+} -result {0 {}}
+test listobj-12.3 {Tcl_ListObjIndex memory leaks for lseq} -constraints {
+    testobj memory
+} -body {
+    list [listobjmemcheck {
+        testobj set 1 [lseq 1000]
+        set errorMessage [testlistobj indexmemcheck 1]
+        testobj freeallvars
+    }] $errorMessage
+} -result {0 {}}
+
+test listobj-13.1 {Tcl_ListObjGetElements memory leaks for native lists} -constraints {
+    testobj memory
+} -body {
+    list [listobjmemcheck {
+        testobj set 1 [lrepeat 1000 x]
+        set errorMessage [testlistobj getelementsmemcheck 1]
+        testobj freeallvars
+    }] $errorMessage
+} -result {0 {}}
+test listobj-13.2 {Tcl_ListObjElements memory leaks for native lists with spans} -constraints {
+    testobj memory
+} -body {
+    list [listobjmemcheck {
+        testobj set 1 [testlistrep new 1000 100 100]
+        set errorMessage [testlistobj getelementsmemcheck 1]
+        testobj freeallvars
+    }] $errorMessage
+} -result {0 {}}
+test listobj-13.3 {Tcl_ListObjElements memory leaks for lseq} -constraints {
+    testobj memory
+} -body {
+    list [listobjmemcheck {
+        testobj set 1 [lseq 1000]
+        set errorMessage [testlistobj getelementsmemcheck 1]
+        testobj freeallvars
+    }] $errorMessage
+} -result {0 {}}
+
 # cleanup
 ::tcltest::cleanupTests
 return