Fix [Bug 2962664] by forcing oo::object deletion on oo::class deletion.

3 files changed, 34 insertions, 12 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index e6c86c7..7ae6ac0 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOO.c,v 1.33 2010/02/15 22:56:20 nijtmans Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.34 2010/03/04 23:42:53 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -297,6 +297,7 @@ InitFoundation(
     ckfree((char *) fPtr->objectCls->superclasses.list);
     fPtr->objectCls->superclasses.list = NULL;
     fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
+    fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
     TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
     TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
     AddRef(fPtr->objectCls->thisPtr);
@@ -705,8 +706,7 @@ ObjectRenamedTrace(
     oPtr->flags |= OBJECT_DELETED;
 
     if (!(oPtr->flags & DESTRUCTOR_CALLED) && (!Tcl_InterpDeleted(interp)
-	    || (oPtr != oPtr->fPtr->objectCls->thisPtr
-	    && oPtr != oPtr->fPtr->classCls->thisPtr))) {
+	    || (oPtr->flags & (ROOT_OBJECT|ROOT_CLASS)))) {
 	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
 	oPtr->flags |= DESTRUCTOR_CALLED;
 	if (contextPtr != NULL) {
@@ -731,15 +731,33 @@ ObjectRenamedTrace(
      * and nuke the namespace (which triggers the final crushing of the object
      * structure itself).
      *
-     * The namespace is only deleted if it hasn't already been deleted. [Bug
-     * 2950259]
+     * The class of classes needs some special care; if it is deleted (and
+     * we're not killing the whole interpreter) we force the delete of the
+     * class of objects 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 (!Tcl_InterpDeleted(interp)) {
+	if ((oPtr->flags & ROOT_OBJECT) && oPtr->fPtr->classCls != NULL) {
+	    Tcl_DeleteCommandFromToken(interp,
+		    oPtr->fPtr->classCls->thisPtr->command);
+	} else if (oPtr->flags & ROOT_CLASS) {
+	    oPtr->fPtr->classCls = NULL;
+	}
+    }
+
     clsPtr = oPtr->classPtr;
     if (clsPtr != NULL) {
 	AddRef(clsPtr);
 	ReleaseClassContents(interp, oPtr);
     }
+
+    /*
+     * The namespace is only deleted if it hasn't already been deleted. [Bug
+     * 2950259]
+     */
+
     if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
 	Tcl_DeleteNamespace(oPtr->namespacePtr);
     }
@@ -1644,7 +1662,7 @@ Tcl_CopyObjectInstance(
 		NULL);
 	return NULL;
     }
-    if (oPtr->classPtr == GetFoundation(interp)->classCls) {
+    if (oPtr->flags & ROOT_CLASS) {
 	Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
 	return NULL;
     }
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 2fb9ce5..ad088af 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOODefineCmds.c,v 1.11 2009/05/04 17:39:51 dkf Exp $
+ * RCS: @(#) $Id: tclOODefineCmds.c,v 1.12 2010/03/04 23:42:54 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -1043,12 +1043,12 @@ TclOODefineClassObjCmd(
     if (oPtr == NULL) {
 	return TCL_ERROR;
     }
-    if (oPtr == fPtr->objectCls->thisPtr) {
+    if (oPtr->flags & ROOT_OBJECT) {
 	Tcl_AppendResult(interp,
-		"may not modify the class of the root object", NULL);
+		"may not modify the class of the root object class", NULL);
 	return TCL_ERROR;
     }
-    if (oPtr == fPtr->classCls->thisPtr) {
+    if (oPtr->flags & ROOT_CLASS) {
 	Tcl_AppendResult(interp,
 		"may not modify the class of the class of classes", NULL);
 	return TCL_ERROR;
@@ -1679,7 +1679,7 @@ TclOODefineSuperclassObjCmd(
 		NULL);
 	return TCL_ERROR;
     }
-    if (oPtr == fPtr->objectCls->thisPtr) {
+    if (oPtr->flags & ROOT_OBJECT) {
 	Tcl_AppendResult(interp,
 		"may not modify the superclass of the root object", NULL);
 	return TCL_ERROR;
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index dc52638..2103dc0 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOOInt.h,v 1.15 2010/01/29 16:17:20 nijtmans Exp $
+ * RCS: @(#) $Id: tclOOInt.h,v 1.16 2010/03/04 23:42:54 dkf Exp $
  */
 
 #ifndef TCL_OO_INTERNAL_H
@@ -212,6 +212,10 @@ typedef struct Object {
 				 * instance of the class, and has had nothing
 				 * added that changes the dispatch chain (i.e.
 				 * no methods, mixins, or filters. */
+#define ROOT_CLASS 0x8000	/* Flag to say that this object is the root
+				 * class of classes, and should be treated
+				 * specially during teardown (and in a few
+				 * other spots). */
 
 /*
  * And the definition of a class. Note that every class also has an associated