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

5 files changed, 89 insertions, 34 deletions

diff --git a/ChangeLog b/ChangeLog
index 2c9b6f8..90a0375 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,36 +1,45 @@
+2010-03-04  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOO.c (ObjectRenamedTrace): Add special handling so that
+	when the class of classes is deleted, so is the class of objects.
+	Immediately. [Bug 2962664]
+
+	* generic/tclOOInt.h (ROOT_CLASS): Add new flag for specially marking
+	the root class. Simpler than the  
+
 2010-03-04  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclGetDate.y     3 unnecessary MODULE_SCOPE
-	* generic/tclDate.c        symbols
-	* generic/tclStubLib.c     Split tommath stub lib
-	* generic/tclTomMathStubLib.c   in separate file.
-	* win/makefile.bc
-	* win/Makefile.in
-	* win/makefile.vc
-	* win/tcl.dsp
-	* unix/Makefile.in
-	* unix/tcl.m4           Cygwin only gives warning
-	* unix/configure        using -fvisibility=hidden
-	* compat/strncasecmp.c     A few more const's
-	* compat/strtod.c
-	* compat/strtoul.c
+	* generic/tclGetDate.y:    3 unnecessary MODULE_SCOPE
+	* generic/tclDate.c:       symbols
+	* generic/tclStubLib.c:    Split tommath stub lib
+	* generic/tclTomMathStubLib.c:  in separate file.
+	* win/makefile.bc:
+	* win/Makefile.in:
+	* win/makefile.vc:
+	* win/tcl.dsp:
+	* unix/Makefile.in:
+	* unix/tcl.m4:          Cygwin only gives warning
+	* unix/configure:       using -fvisibility=hidden
+	* compat/strncasecmp.c: A few more const's
+	* compat/strtod.c:
+	* compat/strtoul.c:
 
 2010-03-03  Andreas Kupries <andreask@activestate.com>
 
 	* doc/refchan.n: Followup to ChangeLog entry 2009-10-07
-	(generic/tclIORChan.c). Fixed the documentation to explain that
-	errno numbers are operating system dependent, and reworked the
-	associated example.
+	(generic/tclIORChan.c). Fixed the documentation to explain that errno
+	numbers are operating system dependent, and reworked the associated
+	example.
 
 2010-03-02  Jan Nijtmans  <nijtmans@users.sf.net>
 
-    * unix/tcl.m4      [Enh 2959069] Support for -fvisibility=hidden
-    * unix/configure   (regenerated with autoconf-2.59)
+	* unix/tcl.m4:     [FRQ 2959069]: Support for -fvisibility=hidden
+	* unix/configure   (regenerated with autoconf-2.59)
 
 2010-03-01  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
-	* unix/tclUnixSock.c: Refrain  from a possibly lengthy reverse-DNS
-	lookup  on  0.0.0.0  when  calling [fconfigure  -sockname]  on  an
+	* unix/tclUnixSock.c: Refrain from a possibly lengthy reverse-DNS
+	lookup on 0.0.0.0 when calling [fconfigure -sockname] on an
 	universally-bound (default) server socket.
 
 	* generic/tclIndexObj.c: fix [AT 86258]: special-casing of empty
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
diff --git a/tests/oo.test b/tests/oo.test
index fbb8971..adcab4b 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -7,7 +7,7 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: oo.test,v 1.37 2010/02/15 11:53:45 dkf Exp $
+# RCS: @(#) $Id: oo.test,v 1.38 2010/03/04 23:42:54 dkf Exp $
 
 package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -72,6 +72,30 @@ test oo-0.5 {testing literal leak on interp delete} memory {
 	interp delete foo
     }
 } 0
+test oo-0.6 {cleaning the core class pair; way #1} -setup {
+    interp create t
+    initInterpreter t
+} -body {
+    t eval {
+	package require TclOO
+	namespace path oo
+	list [catch {class destroy} m] $m [catch {object destroy} m] $m
+    }
+} -cleanup {
+    interp delete t
+} -result {0 {} 1 {invalid command name "object"}}
+test oo-0.7 {cleaning the core class pair; way #2} -setup {
+    interp create t
+    initInterpreter t
+} -body {
+    t eval {
+	package require TclOO
+	namespace path oo
+	list [catch {object destroy} m] $m [catch {class destroy} m] $m
+    }
+} -cleanup {
+    interp delete t
+} -result {0 {} 1 {invalid command name "class"}}
 
 test oo-1.1 {basic test of OO functionality: no classes} {
     set result {}