From e0064189465e2ea63ca9e2dd531928a14c968f52 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 18 Oct 2018 14:58:28 +0000 Subject: Tests for advanced object mutation issues. --- generic/tclOODefineCmds.c | 22 +++++++++++++- tests/oo.test | 77 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 98 insertions(+), 1 deletion(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index c924d2b..f5fe676 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1083,6 +1083,8 @@ TclOODefineClassObjCmd( { Object *oPtr; Class *clsPtr; + Foundation *fPtr = TclOOGetFoundation(interp); + int wasClass, willBeClass; /* * Parse the context to get the object to operate on. @@ -1118,12 +1120,20 @@ TclOODefineClassObjCmd( if (clsPtr == NULL) { return TCL_ERROR; } - + if (oPtr == clsPtr->thisPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not change classes into an instance of themselves", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } /* * Set the object's class. */ + wasClass = (oPtr->classPtr != NULL); + willBeClass = (TclOOIsReachable(fPtr->classCls, clsPtr)); + if (oPtr->selfCls != clsPtr) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); TclOODecrRefCount(oPtr->selfCls->thisPtr); @@ -1131,6 +1141,16 @@ TclOODefineClassObjCmd( AddRef(oPtr->selfCls->thisPtr); TclOOAddToInstances(oPtr, oPtr->selfCls); + /* + * Create or delete the class guts if necessary. + */ + + if (wasClass && !willBeClass) { + /* TODO: DELETE THE STRUCTURE */ + } else if (!wasClass && willBeClass) { + /* TODO: CREATE THE STRUCTURE */ + } + if (oPtr->classPtr != NULL) { BumpGlobalEpoch(interp, oPtr->classPtr); } else { diff --git a/tests/oo.test b/tests/oo.test index 024f890..7f0de4a 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1804,6 +1804,83 @@ test oo-13.4 {OO: changing an object's class} -body { foo destroy bar destroy } -result {::foo ::foo ::foo ::bar} +test oo-13.5 {OO: changing an object's class} -setup { + oo::object create fooObj +} -body { + oo::objdefine fooObj { + class oo::class + } + oo::define fooObj { + method x {} {expr 1+2+3} + } + [fooObj new] x +} -cleanup { + fooObj destroy +} -result 6 +test oo-13.6 {OO: changing an object's class} -setup { + oo::class create foo +} -body { + oo::define foo { + method x {} {expr 1+2+3} + } + foo create bar + oo::objdefine foo { + class oo::object + } + list [catch {bar x} msg] $msg +} -cleanup { + catch {bar destroy} + foo destroy +} -result {1 {}} +test oo-13.7 {OO: changing an object's class} -setup { + oo::class create foo + oo::class create bar + unset -nocomplain result +} -body { + oo::define bar method x {} {return ok} + oo::define foo { + method x {} {expr 1+2+3} + self mixin foo + } + lappend result [foo x] + oo::objdefine foo class bar + lappend result [foo x] +} -cleanup { + foo destroy + bar destroy +} -result {6 ok} +test oo-13.7 {OO: changing an object's class to itself} -setup { + oo::class create foo +} -body { + oo::define foo { + method x {} {expr 1+2+3} + } + oo::objdefine foo class foo +} -cleanup { + foo destroy +} -returnCodes error -result {may not change classes into an instance of themselves} +test oo-13.9 {OO: changing an object's class: roots are special} -setup { + set i [interp create] +} -body { + $i eval { + oo::objdefine oo::object { + class oo::class + } + } +} -cleanup { + interp delete $i +} -returnCodes error -result {may not modify the class of the root object class} +test oo-13.10 {OO: changing an object's class: roots are special} -setup { + set i [interp create] +} -body { + $i eval { + oo::objdefine oo::class { + class oo::object + } + } +} -cleanup { + interp delete $i +} -returnCodes error -result {may not modify the class of the class of classes} # todo: changing a class subtype (metaclass) to another class subtype test oo-14.1 {OO: mixins} { -- cgit v0.12 From 20213492498c729f4a953da797793ba5471607d8 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 18 Oct 2018 21:38:08 +0000 Subject: Make fundamental mutation work. MAGICAL MAGIC MAGICS MAGIC. Abracadabra. --- generic/tclOO.c | 109 +++++++++++++++++++++++++++++----------------- generic/tclOOCall.c | 1 - generic/tclOODefineCmds.c | 14 +++++- generic/tclOOInt.h | 8 ++++ tests/oo.test | 17 +++++--- 5 files changed, 101 insertions(+), 48 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 83646a8..573df3e 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -56,7 +56,6 @@ static const struct { * Function declarations for things defined in this file. */ -static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj); static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, Namespace *nsPtr, const char *nsNameStr); static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, @@ -79,8 +78,6 @@ static void ObjectNamespaceDeleted(ClientData clientData); static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); -static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); -static void DeleteDescendants(Tcl_Interp *interp,Object *oPtr); static inline void SquelchCachedName(Object *oPtr); static int PublicObjectCmd(ClientData clientData, @@ -392,10 +389,10 @@ InitFoundation( /* Stand up a phony class for bootstrapping. */ fPtr->objectCls = &fakeCls; - /* referenced in AllocClass to increment the refCount. */ + /* referenced in TclOOAllocClass to increment the refCount. */ fakeCls.thisPtr = &fakeObject; - fPtr->objectCls = AllocClass(interp, + fPtr->objectCls = TclOOAllocClass(interp, AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); /* Corresponding TclOODecrRefCount in KillFoudation */ AddRef(fPtr->objectCls->thisPtr); @@ -411,7 +408,7 @@ InitFoundation( fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; - fPtr->classCls = AllocClass(interp, + fPtr->classCls = TclOOAllocClass(interp, AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); /* Corresponding TclOODecrRefCount in KillFoudation */ AddRef(fPtr->classCls->thisPtr); @@ -829,15 +826,15 @@ ObjectRenamedTrace( /* * ---------------------------------------------------------------------- * - * DeleteDescendants -- + * TclOODeleteDescendants -- * * Delete all descendants of a particular class. * * ---------------------------------------------------------------------- */ -static void -DeleteDescendants( +void +TclOODeleteDescendants( Tcl_Interp *interp, /* The interpreter containing the class. */ Object *oPtr) /* The object representing the class. */ { @@ -854,7 +851,8 @@ DeleteDescendants( /* This condition also covers the case where mixinSubclassPtr == * clsPtr */ - if (!Deleted(mixinSubclassPtr->thisPtr)) { + if (!Deleted(mixinSubclassPtr->thisPtr) + && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) { Tcl_DeleteCommandFromToken(interp, mixinSubclassPtr->thisPtr->command); } @@ -872,8 +870,10 @@ DeleteDescendants( 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); + if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr) + && !(subclassPtr->thisPtr->flags & DONT_DELETE)) { + Tcl_DeleteCommandFromToken(interp, + subclassPtr->thisPtr->command); } TclOORemoveFromSubclasses(subclassPtr, clsPtr); } @@ -892,7 +892,8 @@ DeleteDescendants( 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)) { + if (!Deleted(instancePtr) && !IsRoot(instancePtr) && + !(instancePtr->flags & DONT_DELETE)) { Tcl_DeleteCommandFromToken(interp, instancePtr->command); } TclOORemoveFromInstances(instancePtr, clsPtr); @@ -909,7 +910,7 @@ DeleteDescendants( /* * ---------------------------------------------------------------------- * - * ReleaseClassContents -- + * TclOOReleaseClassContents -- * * Tear down the special class data structure, including deleting all * dependent classes and objects. @@ -917,8 +918,8 @@ DeleteDescendants( * ---------------------------------------------------------------------- */ -static void -ReleaseClassContents( +void +TclOOReleaseClassContents( Tcl_Interp *interp, /* The interpreter containing the class. */ Object *oPtr) /* The object representing the class. */ { @@ -940,9 +941,6 @@ ReleaseClassContents( } else if (IsRootObject(oPtr)) { Tcl_Panic("deleting class structure for non-deleted %s", "::oo::object"); - } else { - Tcl_Panic("deleting class structure for non-deleted %s", - "general object"); } } @@ -1037,6 +1035,7 @@ ReleaseClassContents( if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); } + oPtr->classPtr = NULL; } /* @@ -1082,7 +1081,7 @@ ObjectNamespaceDeleted( /* Let the dominoes fall */ if (oPtr->classPtr) { - DeleteDescendants(interp, oPtr); + TclOODeleteDescendants(interp, oPtr); } /* @@ -1194,27 +1193,25 @@ ObjectNamespaceDeleted( } /* - * Because an object can be a class that is an instance of itself, the - * A class object's class structure should only be cleaned after most of - * the cleanup on the object is done. - */ - - - /* + * Because an object can be a class that is an instance of itself, the + * class object's class structure should only be cleaned after most of + * the cleanup on the object is done. + * * The class of objects needs some special care; if it is deleted (and * we're not killing the whole interpreter) we force the delete of the * class of classes now as well. Due to the incestuous nature of those two * classes, if one goes the other must too and yet the tangle can * sometimes not go away automatically; we force it here. [Bug 2962664] */ + if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) - && !Tcl_InterpDeleted(interp)) { + && !Tcl_InterpDeleted(interp)) { Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); } if (oPtr->classPtr != NULL) { - ReleaseClassContents(interp, oPtr); + TclOOReleaseClassContents(interp, oPtr); } /* @@ -1328,6 +1325,37 @@ TclOOAddToInstances( /* * ---------------------------------------------------------------------- * + * TclOORemoveFromMixins -- + * + * Utility function to remove a class from the list of mixins within an + * object. + * + * ---------------------------------------------------------------------- + */ + +int +TclOORemoveFromMixins( + Class *mixinPtr, /* The mixin to remove. */ + Object *oPtr) /* The object (possibly) containing the + * reference to the mixin. */ +{ + int i, res = 0; + Class *mixPtr; + + FOREACH(mixPtr, oPtr->mixins) { + if (mixinPtr == mixPtr) { + RemoveItem(Class, oPtr->mixins, i); + TclOODecrRefCount(mixPtr->thisPtr); + res++; + break; + } + } + return res; +} + +/* + * ---------------------------------------------------------------------- + * * TclOORemoveFromSubclasses -- * * Utility function to remove a class from the list of subclasses within @@ -1381,7 +1409,8 @@ TclOOAddToSubclasses( if (superPtr->subclasses.size == ALLOC_CHUNK) { superPtr->subclasses.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { - superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, sizeof(Class *) * superPtr->subclasses.size); + superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, + sizeof(Class *) * superPtr->subclasses.size); } } superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr; @@ -1456,16 +1485,16 @@ TclOOAddToMixinSubs( /* * ---------------------------------------------------------------------- * - * AllocClass -- + * TclOOAllocClass -- * - * Allocate a basic class. Does not add class to its - * class's instance list. + * Allocate a basic class. Does not add class to its class's instance + * list. * * ---------------------------------------------------------------------- */ -static Class * -AllocClass( +Class * +TclOOAllocClass( Tcl_Interp *interp, /* Interpreter within which to allocate the * class. */ Object *useThisObj) /* Object that is to act as the class @@ -1709,13 +1738,13 @@ TclNewObjectInstanceCommon( if (TclOOIsReachable(fPtr->classCls, classPtr)) { /* - * Is a class, so attach a class structure. Note that the AllocClass - * function splices the structure into the object, so we don't have - * to. Once that's done, we need to repatch the object to have the - * right class since AllocClass interferes with that. + * Is a class, so attach a class structure. Note that the + * TclOOAllocClass function splices the structure into the object, so + * we don't have to. Once that's done, we need to repatch the object + * to have the right class since TclOOAllocClass interferes with that. */ - AllocClass(interp, oPtr); + TclOOAllocClass(interp, oPtr); TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); } else { oPtr->classPtr = NULL; diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index c71425b..a46b8bc 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -1444,7 +1444,6 @@ AddSimpleClassChainToCallContext( if (flags & CONSTRUCTOR) { AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters, filterDecl, flags); - } else if (flags & DESTRUCTOR) { AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters, filterDecl, flags); diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index f5fe676..d5f4878 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1146,9 +1146,19 @@ TclOODefineClassObjCmd( */ if (wasClass && !willBeClass) { - /* TODO: DELETE THE STRUCTURE */ + /* + * This is the most global of all epochs. Bump it! No cache can be + * trusted! + */ + + TclOORemoveFromMixins(oPtr->classPtr, oPtr); + oPtr->fPtr->epoch++; + oPtr->flags |= DONT_DELETE; + TclOODeleteDescendants(interp, oPtr); + oPtr->flags &= ~DONT_DELETE; + TclOOReleaseClassContents(interp, oPtr); } else if (!wasClass && willBeClass) { - /* TODO: CREATE THE STRUCTURE */ + TclOOAllocClass(interp, oPtr); } if (oPtr->classPtr != NULL) { diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 61ead01..e59fe8a 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -214,6 +214,7 @@ typedef struct Object { * other spots). */ #define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the * unknown method handler at that point. */ +#define DONT_DELETE 0x20000 /* Inhibit deletion of this object. */ /* * And the definition of a class. Note that every class also has an associated @@ -484,6 +485,8 @@ MODULE_SCOPE int TclOO_Object_VarName(ClientData clientData, MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr); MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr); +MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp, + Object *useThisObj); MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, @@ -498,6 +501,8 @@ MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr); MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr); MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); +MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp, + Object *oPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, @@ -523,7 +528,10 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr, const DeclaredClassMethod *dcm); MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr); +MODULE_SCOPE void TclOOReleaseClassContents(Tcl_Interp *interp, + Object *oPtr); MODULE_SCOPE int TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); +MODULE_SCOPE int TclOORemoveFromMixins(Class *mixinPtr, Object *oPtr); MODULE_SCOPE int TclOORemoveFromMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE int TclOORemoveFromSubclasses(Class *subPtr, diff --git a/tests/oo.test b/tests/oo.test index 7f0de4a..0558746 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1804,7 +1804,7 @@ test oo-13.4 {OO: changing an object's class} -body { foo destroy bar destroy } -result {::foo ::foo ::foo ::bar} -test oo-13.5 {OO: changing an object's class} -setup { +test oo-13.5 {OO: changing an object's class: non-class to class} -setup { oo::object create fooObj } -body { oo::objdefine fooObj { @@ -1817,21 +1817,28 @@ test oo-13.5 {OO: changing an object's class} -setup { } -cleanup { fooObj destroy } -result 6 -test oo-13.6 {OO: changing an object's class} -setup { +test oo-13.6 {OO: changing an object's class: class to non-class} -setup { oo::class create foo + unset -nocomplain ::result } -body { + set result dangling oo::define foo { method x {} {expr 1+2+3} } + oo::class create boo { + superclass foo + destructor {set ::result "ok"} + } + boo new foo create bar oo::objdefine foo { class oo::object } - list [catch {bar x} msg] $msg + list $result [catch {bar x} msg] $msg } -cleanup { catch {bar destroy} foo destroy -} -result {1 {}} +} -result {ok 1 {invalid command name "bar"}} test oo-13.7 {OO: changing an object's class} -setup { oo::class create foo oo::class create bar @@ -1849,7 +1856,7 @@ test oo-13.7 {OO: changing an object's class} -setup { foo destroy bar destroy } -result {6 ok} -test oo-13.7 {OO: changing an object's class to itself} -setup { +test oo-13.8 {OO: changing an object's class to itself} -setup { oo::class create foo } -body { oo::define foo { -- cgit v0.12 From 09446c7544e32d0eca9c0c68d7917729e6c33ee8 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 19 Oct 2018 09:59:14 +0000 Subject: Added another test case. This one is OK. --- tests/oo.test | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index 0558746..db5c14f 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1888,6 +1888,22 @@ test oo-13.10 {OO: changing an object's class: roots are special} -setup { } -cleanup { interp delete $i } -returnCodes error -result {may not modify the class of the class of classes} +test oo-13.11 {OO: changing an object's class in a tricky place} -setup { + oo::class create cls + unset -nocomplain result +} -body { + set result gorp + list [catch { + oo::define cls { + method x {} {return} + self class oo::object + ::set ::result ok + method y {} {return}; # I'm sorry, Dave. I'm afraid I can't do that. + } + } msg] $msg $result +} -cleanup { + cls destroy +} -result {1 {attempt to misuse API} ok} # todo: changing a class subtype (metaclass) to another class subtype test oo-14.1 {OO: mixins} { -- cgit v0.12