diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclTestObj.c | 323 |
1 files changed, 216 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; } |