summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclOO.c109
-rw-r--r--generic/tclOOCall.c1
-rw-r--r--generic/tclOODefineCmds.c14
-rw-r--r--generic/tclOOInt.h8
-rw-r--r--tests/oo.test17
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 {
generated by cgit v0.12 at 2024-11-16 03:07:57 (GMT)