summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2018-03-14 22:17:51 (GMT)
committerdgp <dgp@users.sourceforge.net>2018-03-14 22:17:51 (GMT)
commit99ab923ed55f810fe95753c074c0e7b02f6809e8 (patch)
tree5be4eacb21d2c81585f74ef9cc9864e6a13bf086
parent1bf60bab3cd706cba08c15df5a6a5267d918aeae (diff)
parent72c721f3e71c327c2e70def50fb04f48c4527442 (diff)
downloadtcl-99ab923ed55f810fe95753c074c0e7b02f6809e8.zip
tcl-99ab923ed55f810fe95753c074c0e7b02f6809e8.tar.gz
tcl-99ab923ed55f810fe95753c074c0e7b02f6809e8.tar.bz2
Memleak and lifetime management fixes for components of the OO system.
-rw-r--r--generic/tclOO.c224
-rw-r--r--generic/tclOODefineCmds.c47
-rw-r--r--tests/oo.test222
3 files changed, 304 insertions, 189 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 587e46d..83646a8 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -397,35 +397,46 @@ InitFoundation(
fPtr->objectCls = AllocClass(interp,
AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
+ /* Corresponding TclOODecrRefCount in KillFoudation */
+ AddRef(fPtr->objectCls->thisPtr);
+
+ /* This is why it is unnecessary in this routine to replace the
+ * incremented reference count of fPtr->objectCls that was swallowed by
+ * fakeObject. */
+ fPtr->objectCls->superclasses.num = 0;
+ ckfree(fPtr->objectCls->superclasses.list);
+ fPtr->objectCls->superclasses.list = NULL;
+
+ /* special initialization for the primordial objects */
+ fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
+ fPtr->objectCls->flags |= ROOT_OBJECT;
+
fPtr->classCls = AllocClass(interp,
AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
+ /* Corresponding TclOODecrRefCount in KillFoudation */
+ AddRef(fPtr->classCls->thisPtr);
+
+ /*
+ * Increment reference counts for each reference because these
+ * relationships can be dynamically changed.
+ *
+ * Corresponding TclOODecrRefCount for all incremented refcounts is in
+ * KillFoundation.
+ */
/* Rewire bootstrapped objects. */
fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
- fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
-
- AddRef(fPtr->objectCls->thisPtr);
AddRef(fPtr->classCls->thisPtr);
- AddRef(fPtr->classCls->thisPtr->selfCls->thisPtr);
- AddRef(fPtr->objectCls->thisPtr->selfCls->thisPtr);
-
- /* special initialization for the primordial objects */
- fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
- fPtr->objectCls->flags |= ROOT_OBJECT;
+ TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
- /* This is why it is unnecessary in this routine to make up for the
- * incremented reference count of fPtr->objectCls that was sallwed by
- * fakeObject. */
- fPtr->objectCls->superclasses.num = 0;
- ckfree(fPtr->objectCls->superclasses.list);
- fPtr->objectCls->superclasses.list = NULL;
+ fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
+ AddRef(fPtr->classCls->thisPtr);
+ TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
fPtr->classCls->flags |= ROOT_CLASS;
/* Standard initialization for new Objects */
- TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
- TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);
/*
@@ -552,20 +563,14 @@ KillFoundation(
{
Foundation *fPtr = GetFoundation(interp);
- /*
- * Crude mechanism to avoid leaking the Object struct of the
- * foundation components oo::object and oo::class
- *
- * Should probably be replaced with something more elegantly designed.
- */
- while (TclOODecrRefCount(fPtr->objectCls->thisPtr) == 0) {};
- while (TclOODecrRefCount(fPtr->classCls->thisPtr) == 0) {};
-
TclDecrRefCount(fPtr->unknownMethodNameObj);
TclDecrRefCount(fPtr->constructorName);
TclDecrRefCount(fPtr->destructorName);
TclDecrRefCount(fPtr->clonedName);
TclDecrRefCount(fPtr->defineName);
+ TclOODecrRefCount(fPtr->objectCls->thisPtr);
+ TclOODecrRefCount(fPtr->classCls->thisPtr);
+
ckfree(fPtr);
}
@@ -649,12 +654,16 @@ AllocObject(
Tcl_ResetResult(interp);
}
+
+ configNamespace:
+
+ ((Namespace *)oPtr->namespacePtr)->refCount++;
+
/*
* Make the namespace know about the helper commands. This grants access
* to the [self] and [next] commands.
*/
- configNamespace:
if (fPtr->helpersNs != NULL) {
TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
}
@@ -820,10 +829,9 @@ ObjectRenamedTrace(
/*
* ----------------------------------------------------------------------
*
- * ReleaseClassContents --
+ * DeleteDescendants --
*
- * Tear down the special class data structure, including deleting all
- * dependent classes and objects.
+ * Delete all descendants of a particular class.
*
* ----------------------------------------------------------------------
*/
@@ -835,50 +843,79 @@ DeleteDescendants(
{
Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr;
Object *instancePtr;
- int i;
/*
* Squelch classes that this class has been mixed into.
*/
- FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
- /* This condition also covers the case where mixinSubclassPtr ==
- * clsPtr
- */
- if (!Deleted(mixinSubclassPtr->thisPtr)) {
- Tcl_DeleteCommandFromToken(interp,
- mixinSubclassPtr->thisPtr->command);
+ if (clsPtr->mixinSubs.num > 0) {
+ while (clsPtr->mixinSubs.num > 0) {
+ mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1];
+ /* This condition also covers the case where mixinSubclassPtr ==
+ * clsPtr
+ */
+ if (!Deleted(mixinSubclassPtr->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp,
+ mixinSubclassPtr->thisPtr->command);
+ }
+ TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
}
- i -= TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
- TclOODecrRefCount(mixinSubclassPtr->thisPtr);
+ }
+ if (clsPtr->mixinSubs.size > 0) {
+ ckfree(clsPtr->mixinSubs.list);
+ clsPtr->mixinSubs.size = 0;
}
/*
* Squelch subclasses of this class.
*/
- FOREACH(subclassPtr, clsPtr->subclasses) {
- if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) {
- Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
+ if (clsPtr->subclasses.num > 0) {
+ while (clsPtr->subclasses.num > 0) {
+ subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1];
+ if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) {
+ Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
+ }
+ TclOORemoveFromSubclasses(subclassPtr, clsPtr);
}
- i -= TclOORemoveFromSubclasses(subclassPtr, clsPtr);
- TclOODecrRefCount(subclassPtr->thisPtr);
+ }
+ if (clsPtr->subclasses.size > 0) {
+ ckfree(clsPtr->subclasses.list);
+ clsPtr->subclasses.list = NULL;
+ clsPtr->subclasses.size = 0;
}
/*
* Squelch instances of this class (includes objects we're mixed into).
*/
- if (!IsRootClass(oPtr)) {
- FOREACH(instancePtr, clsPtr->instances) {
+ if (clsPtr->instances.num > 0) {
+ while (clsPtr->instances.num > 0) {
+ instancePtr = clsPtr->instances.list[clsPtr->instances.num-1];
/* This condition also covers the case where instancePtr == oPtr */
if (!Deleted(instancePtr) && !IsRoot(instancePtr)) {
Tcl_DeleteCommandFromToken(interp, instancePtr->command);
}
- i -= TclOORemoveFromInstances(instancePtr, clsPtr);
+ TclOORemoveFromInstances(instancePtr, clsPtr);
}
}
+ if (clsPtr->instances.size > 0) {
+ ckfree(clsPtr->instances.list);
+ clsPtr->instances.list = NULL;
+ clsPtr->instances.size = 0;
+ }
}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ReleaseClassContents --
+ *
+ * Tear down the special class data structure, including deleting all
+ * dependent classes and objects.
+ *
+ * ----------------------------------------------------------------------
+ */
static void
ReleaseClassContents(
@@ -948,21 +985,6 @@ ReleaseClassContents(
}
/*
- * Squelch our instances.
- */
-
- if (clsPtr->instances.num) {
- Object *oPtr;
-
- FOREACH(oPtr, clsPtr->instances) {
- TclOODecrRefCount(oPtr);
- }
- ckfree(clsPtr->instances.list);
- clsPtr->instances.list = NULL;
- clsPtr->instances.num = 0;
- }
-
- /*
* Squelch our metadata.
*/
@@ -978,11 +1000,24 @@ ReleaseClassContents(
clsPtr->metadataPtr = NULL;
}
- FOREACH(tmpClsPtr, clsPtr->mixins) {
- TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
+ if (clsPtr->mixins.num) {
+ FOREACH(tmpClsPtr, clsPtr->mixins) {
+ TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
+ TclOODecrRefCount(tmpClsPtr->thisPtr);
+ }
+ ckfree(clsPtr->mixins.list);
+ clsPtr->mixins.list = NULL;
+ clsPtr->mixins.num = 0;
}
- FOREACH(tmpClsPtr, clsPtr->superclasses) {
- TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
+
+ if (clsPtr->superclasses.num > 0) {
+ FOREACH(tmpClsPtr, clsPtr->superclasses) {
+ TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
+ TclOODecrRefCount(tmpClsPtr->thisPtr);
+ }
+ ckfree(clsPtr->superclasses.list);
+ clsPtr->superclasses.num = 0;
+ clsPtr->superclasses.list = NULL;
}
FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
@@ -1110,10 +1145,11 @@ ObjectNamespaceDeleted(
/* To do: Should this be protected with a * !IsRoot() condition? */
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
- FOREACH(mixinPtr, oPtr->mixins) {
- i -= TclOORemoveFromInstances(oPtr, mixinPtr);
- }
- if (i) {
+ if (oPtr->mixins.num > 0) {
+ FOREACH(mixinPtr, oPtr->mixins) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
+ }
ckfree(oPtr->mixins.list);
}
@@ -1185,7 +1221,9 @@ ObjectNamespaceDeleted(
* Delete the object structure itself.
*/
+ TclNsDecrRefCount((Namespace *)oPtr->namespacePtr);
oPtr->namespacePtr = NULL;
+ TclOODecrRefCount(oPtr->selfCls->thisPtr);
oPtr->selfCls = NULL;
TclOODecrRefCount(oPtr);
return;
@@ -1204,13 +1242,7 @@ ObjectNamespaceDeleted(
*/
int TclOODecrRefCount(Object *oPtr) {
if (oPtr->refCount-- <= 1) {
- Class *clsPtr = oPtr->classPtr;
if (oPtr->classPtr != NULL) {
- ckfree(clsPtr->superclasses.list);
- ckfree(clsPtr->subclasses.list);
- ckfree(clsPtr->instances.list);
- ckfree(clsPtr->mixinSubs.list);
- ckfree(clsPtr->mixins.list);
ckfree(oPtr->classPtr);
}
ckfree(oPtr);
@@ -1250,9 +1282,6 @@ TclOORemoveFromInstances(
{
int i, res = 0;
Object *instPtr;
- if (Deleted(clsPtr->thisPtr)) {
- return res;
- }
FOREACH(instPtr, clsPtr->instances) {
if (oPtr == instPtr) {
@@ -1315,9 +1344,6 @@ TclOORemoveFromSubclasses(
{
int i, res = 0;
Class *subclsPtr;
- if (Deleted(superPtr->thisPtr)) {
- return res;
- }
FOREACH(subclsPtr, superPtr->subclasses) {
if (subPtr == subclsPtr) {
@@ -1382,10 +1408,6 @@ TclOORemoveFromMixinSubs(
int i, res = 0;
Class *subclsPtr;
- if (Deleted(superPtr->thisPtr)) {
- return res;
- }
-
FOREACH(subclsPtr, superPtr->mixinSubs) {
if (subPtr == subclsPtr) {
RemoveItem(Class, superPtr->mixinSubs, i);
@@ -1678,6 +1700,7 @@ TclNewObjectInstanceCommon(
oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
oPtr->selfCls = classPtr;
+ AddRef(classPtr->thisPtr);
TclOOAddToInstances(oPtr, classPtr);
/*
* Check to see if we're really creating a class. If so, allocate the
@@ -1814,16 +1837,22 @@ Tcl_CopyObjectInstance(
* Copy the object's mixin references to the new object.
*/
- FOREACH(mixinPtr, o2Ptr->mixins) {
- if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
- TclOORemoveFromInstances(o2Ptr, mixinPtr);
+ if (o2Ptr->mixins.num != 0) {
+ FOREACH(mixinPtr, o2Ptr->mixins) {
+ if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
+ TclOORemoveFromInstances(o2Ptr, mixinPtr);
+ }
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
+ ckfree(o2Ptr->mixins.list);
}
DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
FOREACH(mixinPtr, o2Ptr->mixins) {
if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
TclOOAddToInstances(o2Ptr, mixinPtr);
}
+ /* For the reference just created in DUPLICATE */
+ AddRef(mixinPtr->thisPtr);
}
/*
@@ -1901,6 +1930,7 @@ Tcl_CopyObjectInstance(
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOORemoveFromSubclasses(cls2Ptr, superPtr);
+ TclOODecrRefCount(superPtr->thisPtr);
}
if (cls2Ptr->superclasses.num) {
cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list,
@@ -1914,6 +1944,11 @@ Tcl_CopyObjectInstance(
cls2Ptr->superclasses.num = clsPtr->superclasses.num;
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOOAddToSubclasses(cls2Ptr, superPtr);
+
+ /* For the new item in cls2Ptr->superclasses that memcpy just
+ * created
+ */
+ AddRef(superPtr->thisPtr);
}
/*
@@ -1939,15 +1974,18 @@ Tcl_CopyObjectInstance(
* references to the duplicate).
*/
- FOREACH(mixinPtr, cls2Ptr->mixins) {
- TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
- }
if (cls2Ptr->mixins.num != 0) {
+ FOREACH(mixinPtr, cls2Ptr->mixins) {
+ TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
+ }
ckfree(clsPtr->mixins.list);
}
DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
FOREACH(mixinPtr, cls2Ptr->mixins) {
TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
+ /* For the copy just created in DUPLICATE */
+ AddRef(mixinPtr->thisPtr);
}
/*
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index d05d899..648ad02 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -327,6 +327,7 @@ TclOOObjectSetMixins(
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
TclOORemoveFromInstances(oPtr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
ckfree(oPtr->mixins.list);
oPtr->mixins.num = 0;
@@ -338,6 +339,7 @@ TclOOObjectSetMixins(
if (mixinPtr && mixinPtr != oPtr->selfCls) {
TclOORemoveFromInstances(oPtr, mixinPtr);
}
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
oPtr->mixins.list = ckrealloc(oPtr->mixins.list,
sizeof(Class *) * numMixins);
@@ -350,10 +352,8 @@ TclOOObjectSetMixins(
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr != oPtr->selfCls) {
TclOOAddToInstances(oPtr, mixinPtr);
- /* Corresponding TclOODecrRefCount() is in the caller of this
- * function.
- */
- TclOODecrRefCount(mixinPtr->thisPtr);
+ /* For the new copy created by memcpy */
+ AddRef(mixinPtr->thisPtr);
}
}
}
@@ -383,6 +383,7 @@ TclOOClassSetMixins(
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
ckfree(classPtr->mixins.list);
classPtr->mixins.num = 0;
@@ -391,6 +392,7 @@ TclOOClassSetMixins(
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
classPtr->mixins.list = ckrealloc(classPtr->mixins.list,
sizeof(Class *) * numMixins);
@@ -401,10 +403,8 @@ TclOOClassSetMixins(
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, classPtr->mixins) {
TclOOAddToMixinSubs(classPtr, mixinPtr);
- /* Corresponding TclOODecrRefCount() is in the caller of this
- * function
- */
- TclOODecrRefCount(mixinPtr->thisPtr);
+ /* For the new copy created by memcpy */
+ AddRef(mixinPtr->thisPtr);
}
}
BumpGlobalEpoch(interp, classPtr);
@@ -1126,11 +1126,11 @@ TclOODefineClassObjCmd(
if (oPtr->selfCls != clsPtr) {
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
-
- /* Reference count already incremented 3 lines up. */
+ TclOODecrRefCount(oPtr->selfCls->thisPtr);
oPtr->selfCls = clsPtr;
-
+ AddRef(oPtr->selfCls->thisPtr);
TclOOAddToInstances(oPtr, oPtr->selfCls);
+
if (oPtr->classPtr != NULL) {
BumpGlobalEpoch(interp, oPtr->classPtr);
} else {
@@ -1586,10 +1586,6 @@ TclOODefineMixinObjCmd(
goto freeAndError;
}
mixins[i-1] = clsPtr;
- /* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins,
- * TclOOClassSetMixinsk, or just below if this function fails.
- */
- AddRef(mixins[i-1]->thisPtr);
}
if (isInstanceMixin) {
@@ -1602,9 +1598,6 @@ TclOODefineMixinObjCmd(
return TCL_OK;
freeAndError:
- while (--i > 0) {
- TclOODecrRefCount(mixins[i]->thisPtr);
- }
TclStackFree(interp, mixins);
return TCL_ERROR;
}
@@ -2029,10 +2022,6 @@ ClassMixinSet(
Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
goto freeAndError;
}
- /* Corresponding TclOODecrRefCount() is in TclOOClassSetMixins, or just
- * below if this function fails
- */
- AddRef(mixins[i]->thisPtr);
}
TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
@@ -2040,9 +2029,6 @@ ClassMixinSet(
return TCL_OK;
freeAndError:
- while (i-- > 0) {
- TclOODecrRefCount(mixins[i]->thisPtr);
- }
TclStackFree(interp, mixins);
return TCL_ERROR;
}
@@ -2151,7 +2137,6 @@ ClassSuperSet(
superclasses[0] = oPtr->fPtr->objectCls;
}
superc = 1;
- /* Corresponding TclOODecrRefCount is near the end of this function */
AddRef(superclasses[0]->thisPtr);
} else {
for (i=0 ; i<superc ; i++) {
@@ -2197,6 +2182,7 @@ ClassSuperSet(
if (oPtr->classPtr->superclasses.num != 0) {
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
+ TclOODecrRefCount(superPtr->thisPtr);
}
ckfree((char *) oPtr->classPtr->superclasses.list);
}
@@ -2204,8 +2190,6 @@ ClassSuperSet(
oPtr->classPtr->superclasses.num = superc;
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOOAddToSubclasses(oPtr->classPtr, superPtr);
- /* To account for the AddRef() earlier in this function */
- TclOODecrRefCount(superPtr->thisPtr);
}
BumpGlobalEpoch(interp, oPtr->classPtr);
@@ -2496,16 +2480,9 @@ ObjMixinSet(
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
- while (i-- > 0) {
- TclOODecrRefCount(mixins[i]->thisPtr);
- }
TclStackFree(interp, mixins);
return TCL_ERROR;
}
- /* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins() or
- * just above if this function fails.
- */
- AddRef(mixins[i]->thisPtr);
}
TclOOObjectSetMixins(oPtr, mixinc, mixins);
diff --git a/tests/oo.test b/tests/oo.test
index 9cf3133..024f890 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -13,6 +13,13 @@ if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
+
+# The foundational objects oo::object and oo::class are sensitive to reference
+# counting errors and are deallocated only when an interp is deleted, so in
+# this test suite, interp creation and interp deletion are often used in
+# leaktests in order to leverage this sensitivity.
+
+
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
@@ -57,7 +64,13 @@ test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
foo destroy
}
} -constraints memory -result 0
-test oo-0.5 {testing literal leak on interp delete} memory {
+test oo-0.5.1 {testing object foundation cleanup} memory {
+ leaktest {
+ interp create foo
+ interp delete foo
+ }
+} 0
+test oo-0.5.2 {testing literal leak on interp delete} memory {
leaktest {
interp create foo
foo eval {oo::object new}
@@ -265,7 +278,21 @@ test oo-1.18 {OO: create object in NS with same name as global cmd} -setup {
rename test-oo-1.18 {}
A destroy
} -result ::C
-test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
+test oo-1.18.1 {no memory leak: superclass} -setup {
+} -constraints memory -body {
+
+ leaktest {
+ interp create t
+ t eval {
+ oo::class create A {
+ superclass oo::class
+ }
+ }
+ interp delete t
+ }
+} -cleanup {
+} -result 0
+test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup {
proc test-oo-1.18 {} return
} -constraints memory -body {
leaktest {
@@ -278,7 +305,7 @@ test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
} -cleanup {
rename test-oo-1.18 {}
} -result 0
-test oo-1.18.2 {Bug 21c144f0f5} -setup {
+test oo-1.18.3 {Bug 21c144f0f5} -setup {
interp create slave
} -body {
slave eval {
@@ -1502,7 +1529,56 @@ test oo-11.5 {OO: cleanup} {
return done
} done
-test oo-11.6 {
+test oo-11.6.1 {
+ OO: cleanup of when an class is mixed into itself
+} -constraints memory -body {
+ leaktest {
+ interp create interp1
+ oo::class create obj1
+ ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
+ rename obj1 {}
+ interp delete interp1
+ }
+} -result 0 -cleanup {
+}
+
+test oo-11.6.2 {
+ OO: cleanup ReleaseClassContents() where class is mixed into one of its
+ instances
+} -constraints memory -body {
+ leaktest {
+ interp create interp1
+ interp1 eval {
+ oo::class create obj1
+ ::oo::copy obj1 obj2
+ rename obj2 {}
+ rename obj1 {}
+ }
+ interp delete interp1
+ }
+} -result 0 -cleanup {
+}
+
+test oo-11.6.3 {
+ OO: cleanup ReleaseClassContents() where class is mixed into one of its
+ instances
+} -constraints memory -body {
+ leaktest {
+ interp create interp1
+ interp1 eval {
+ oo::class create obj1
+ ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
+
+ ::oo::copy obj1 obj2
+ rename obj2 {}
+ rename obj1 {}
+ }
+ interp delete interp1
+ }
+} -result 0 -cleanup {
+}
+
+test oo-11.6.4 {
OO: cleanup ReleaseClassContents() where class is mixed into one of its
instances
} -body {
@@ -2065,7 +2141,20 @@ test oo-15.12 {OO: object cloning with target NS} -setup {
Super destroy
catch {namespace delete ::existing}
} -result {::existing refers to an existing namespace}
-test oo-15.13 {OO: object cloning with target NS} -setup {
+test oo-15.13.1 {
+ OO: object cloning with target NS
+ Valgrind will report a leak if the reference count of the namespace isn't
+ properly incremented.
+} -setup {
+ oo::class create Cls {}
+} -body {
+ oo::copy Cls Cls2 ::dupens
+ return done
+} -cleanup {
+ Cls destroy
+ Cls2 destroy
+} -result done
+test oo-15.13.2 {OO: object cloning with target NS} -setup {
oo::class create Super
oo::class create Cls {superclass Super}
} -body {
@@ -3660,99 +3749,110 @@ test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup {
cls destroy
} -result {0 {}}
-oo::class create SampleSlot {
- superclass oo::Slot
- constructor {} {
- variable contents {a b c} ops {}
- }
- method contents {} {variable contents; return $contents}
- method ops {} {variable ops; return $ops}
- method Get {} {
- variable contents
- variable ops
- lappend ops [info level] Get
- return $contents
- }
- method Set {lst} {
- variable contents $lst
- variable ops
- lappend ops [info level] Set $lst
- return
+proc SampleSlotSetup script {
+ set script0 {
+ oo::class create SampleSlot {
+ superclass oo::Slot
+ constructor {} {
+ variable contents {a b c} ops {}
+ }
+ method contents {} {variable contents; return $contents}
+ method ops {} {variable ops; return $ops}
+ method Get {} {
+ variable contents
+ variable ops
+ lappend ops [info level] Get
+ return $contents
+ }
+ method Set {lst} {
+ variable contents $lst
+ variable ops
+ lappend ops [info level] Set $lst
+ return
+ }
+ }
}
+ append script0 \n$script
}
-test oo-32.1 {TIP 380: slots - class test} -setup {
+proc SampleSlotCleanup script {
+ set script0 {
+ SampleSlot destroy
+ }
+ append script \n$script0
+}
+
+test oo-32.1 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {a b c} {}}
-test oo-32.2 {TIP 380: slots - class test} -setup {
+}] -result {0 {a b c} {}}
+test oo-32.2 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot -clear] \
[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {} {} {1 Set {}}}
-test oo-32.3 {TIP 380: slots - class test} -setup {
+}] -result {0 {} {} {1 Set {}}}
+test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot -append g h i] \
[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
-test oo-32.4 {TIP 380: slots - class test} -setup {
+}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
+test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot -set d e f] \
[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {} {d e f} {1 Set {d e f}}}
-test oo-32.5 {TIP 380: slots - class test} -setup {
+}] -result {0 {} {d e f} {1 Set {d e f}}}
+test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
+}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
-test oo-33.1 {TIP 380: slots - defaulting} -setup {
+test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
-} -body {
+}] -body {
list [$s x y] [$s contents]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename $s {}
-} -result {{} {a b c x y}}
-test oo-33.2 {TIP 380: slots - defaulting} -setup {
+}] -result {{} {a b c x y}}
+test oo-33.2 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
-} -body {
+}] -body {
list [$s destroy; $s unknown] [$s contents]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename $s {}
-} -result {{} {a b c destroy unknown}}
-test oo-33.3 {TIP 380: slots - defaulting} -setup {
+}] -result {{} {a b c destroy unknown}}
+test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
-} -body {
+}] -body {
oo::objdefine $s forward --default-operation my -set
list [$s destroy; $s unknown] [$s contents] [$s ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename $s {}
-} -result {{} unknown {1 Set destroy 1 Set unknown}}
-test oo-33.4 {TIP 380: slots - errors} -setup {
+}] -result {{} unknown {1 Set destroy 1 Set unknown}}
+test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
set s [SampleSlot new]
-} -body {
+}] -body {
# Method names beginning with "-" are special to slots
$s -grill q
-} -returnCodes error -cleanup {
+} -returnCodes error -cleanup [SampleSlotCleanup {
rename $s {}
-} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}
-
-SampleSlot destroy
+}] -result \
+ {unknown method "-grill": must be -append, -clear, -set, contents or ops}
test oo-34.1 {TIP 380: slots - presence} -setup {
set obj [oo::object new]