diff options
| -rw-r--r-- | generic/tclOO.c | 249 | ||||
| -rw-r--r-- | generic/tclOODefineCmds.c | 73 | ||||
| -rw-r--r-- | tests/oo.test | 222 |
3 files changed, 305 insertions, 239 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c index dcf48ef..d68131d 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -511,61 +511,53 @@ InitClassSystemRoots( Class fakeCls; Object fakeObject; - /* - * Stand up a phony class for bootstrapping. - */ - + /* Stand up a phony class for bootstrapping. */ fPtr->objectCls = &fakeCls; - - /* - * Referenced in AllocClass to increment the refCount. - */ - + /* referenced in AllocClass to increment the refCount. */ fakeCls.thisPtr = &fakeObject; fPtr->objectCls = AllocClass(interp, AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); - fPtr->classCls = AllocClass(interp, - AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); - - /* - * Rewire bootstrapped objects. - */ - - fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; - fPtr->classCls->thisPtr->selfCls = fPtr->classCls; - + /* Corresponding TclOODecrRefCount in KillFoudation */ 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. - */ + /* 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); + /* - * 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. + * Increment reference counts for each reference because these + * relationships can be dynamically changed. + * + * Corresponding TclOODecrRefCount for all incremented refcounts is in + * KillFoundation. */ - fPtr->objectCls->superclasses.num = 0; - ckfree(fPtr->objectCls->superclasses.list); - fPtr->objectCls->superclasses.list = NULL; + /* Rewire bootstrapped objects. */ + fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; + AddRef(fPtr->classCls->thisPtr); + TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); + + 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); + /* Standard initialization for new Objects */ TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); /* @@ -632,20 +624,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); } @@ -729,12 +715,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); } @@ -901,10 +891,9 @@ ObjectRenamedTrace( /* * ---------------------------------------------------------------------- * - * DeleteDescendants, ReleaseClassContents -- + * DeleteDescendants -- * - * Tear down the special class data structure, including deleting all - * dependent classes and objects. + * Delete all descendants of a particular class. * * ---------------------------------------------------------------------- */ @@ -916,44 +905,55 @@ 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 */ @@ -961,10 +961,26 @@ DeleteDescendants( 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( @@ -1034,21 +1050,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. */ @@ -1064,11 +1065,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) { @@ -1204,10 +1218,11 @@ ObjectNamespaceDeleted( 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); } @@ -1276,7 +1291,9 @@ ObjectNamespaceDeleted( * Delete the object structure itself. */ + TclNsDecrRefCount((Namespace *)oPtr->namespacePtr); oPtr->namespacePtr = NULL; + TclOODecrRefCount(oPtr->selfCls->thisPtr); oPtr->selfCls = NULL; TclOODecrRefCount(oPtr); return; @@ -1299,14 +1316,8 @@ 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); @@ -1335,10 +1346,6 @@ TclOORemoveFromInstances( int i, res = 0; Object *instPtr; - if (Deleted(clsPtr->thisPtr)) { - return res; - } - FOREACH(instPtr, clsPtr->instances) { if (oPtr == instPtr) { RemoveItem(Object, clsPtr->instances, i); @@ -1401,10 +1408,6 @@ TclOORemoveFromSubclasses( int i, res = 0; Class *subclsPtr; - if (Deleted(superPtr->thisPtr)) { - return res; - } - FOREACH(subclsPtr, superPtr->subclasses) { if (subPtr == subclsPtr) { RemoveItem(Class, superPtr->subclasses, i); @@ -1469,10 +1472,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); @@ -1780,6 +1779,7 @@ TclNewObjectInstanceCommon( oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr); oPtr->selfCls = classPtr; + AddRef(classPtr->thisPtr); TclOOAddToInstances(oPtr, classPtr); /* @@ -1925,16 +1925,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); } /* @@ -2012,6 +2018,7 @@ Tcl_CopyObjectInstance( FOREACH(superPtr, cls2Ptr->superclasses) { TclOORemoveFromSubclasses(cls2Ptr, superPtr); + TclOODecrRefCount(superPtr->thisPtr); } if (cls2Ptr->superclasses.num) { cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list, @@ -2025,6 +2032,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); } /* @@ -2050,15 +2062,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 7c2a641..b443be8 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -332,6 +332,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; @@ -343,6 +344,7 @@ TclOOObjectSetMixins( if (mixinPtr && mixinPtr != oPtr->selfCls) { TclOORemoveFromInstances(oPtr, mixinPtr); } + TclOODecrRefCount(mixinPtr->thisPtr); } oPtr->mixins.list = ckrealloc(oPtr->mixins.list, sizeof(Class *) * numMixins); @@ -355,13 +357,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); } } } @@ -392,6 +389,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; @@ -400,6 +398,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); @@ -410,13 +409,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); @@ -1186,14 +1180,11 @@ TclOODefineClassObjCmd( if (oPtr->selfCls != clsPtr) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); - - /* - * Reference count already incremented a few 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 { @@ -1656,13 +1647,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) { @@ -1675,9 +1659,6 @@ TclOODefineMixinObjCmd( return TCL_OK; freeAndError: - while (--i > 0) { - TclOODecrRefCount(mixins[i]->thisPtr); - } TclStackFree(interp, mixins); return TCL_ERROR; } @@ -2108,13 +2089,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); @@ -2122,9 +2096,6 @@ ClassMixinSet( return TCL_OK; freeAndError: - while (i-- > 0) { - TclOODecrRefCount(mixins[i]->thisPtr); - } TclStackFree(interp, mixins); return TCL_ERROR; } @@ -2234,11 +2205,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++) { @@ -2288,6 +2254,7 @@ ClassSuperSet( if (oPtr->classPtr->superclasses.num != 0) { FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOORemoveFromSubclasses(oPtr->classPtr, superPtr); + TclOODecrRefCount(superPtr->thisPtr); } ckfree(oPtr->classPtr->superclasses.list); } @@ -2295,12 +2262,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); @@ -2594,19 +2555,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 4f9490b..2d23a3c 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 { @@ -3661,99 +3750,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] |