Fix [Bug 2950259] so that deleting an object by killing its namespace will

reliably call the object's destructor.

3 files changed, 69 insertions, 4 deletions

diff --git a/generic/tclInt.h b/generic/tclInt.h
index f66fa33..55782ee 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.461 2010/02/13 18:11:06 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.462 2010/02/15 11:53:44 dkf Exp $
  */
 
 #ifndef _TCLINT
@@ -339,6 +339,12 @@ typedef struct Namespace {
     NamespacePathEntry *commandPathSourceList;
 				/* Linked list of path entries that point to
 				 * this namespace. */
+    Tcl_NamespaceDeleteProc *earlyDeleteProc;
+				/* Just like the deleteProc field (and called
+				 * with the same clientData) but called at the
+				 * start of the deletion process, so there is
+				 * a chance for code to do stuff inside the
+				 * namespace before deletion completes. */
 } Namespace;
 
 /*
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 140c17e..2e8b814 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -22,7 +22,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclNamesp.c,v 1.201 2010/02/14 13:23:03 dkf Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.202 2010/02/15 11:53:44 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -733,6 +733,7 @@ Tcl_CreateNamespace(
     nsPtr->commandPathLength = 0;
     nsPtr->commandPathArray = NULL;
     nsPtr->commandPathSourceList = NULL;
+    nsPtr->earlyDeleteProc = NULL;
 
     if (parentPtr != NULL) {
 	entryPtr = Tcl_CreateHashEntry(
@@ -844,6 +845,26 @@ Tcl_DeleteNamespace(
     Command *cmdPtr;
 
     /*
+     * Give anyone interested - notably TclOO - a chance to use this namespace
+     * normally despite the fact that the namespace is going to go. Allows the
+     * calling of destructors. Will only be called once (unless re-established
+     * by the called function). [Bug 2950259]
+     *
+     * Note that setting this field requires access to the internal definition
+     * of namespaces, so it should only be accessed by code that knows about
+     * being careful with reentrancy.
+     */
+
+    if (nsPtr->earlyDeleteProc != NULL) {
+	Tcl_NamespaceDeleteProc *earlyDeleteProc = nsPtr->earlyDeleteProc;
+
+	nsPtr->earlyDeleteProc = NULL;
+	nsPtr->activationCount++;
+	earlyDeleteProc(nsPtr->clientData);
+	nsPtr->activationCount--;
+    }
+
+    /*
      * Delete all coroutine commands now: break the circular ref cycle between
      * the namespace and the coroutine command [Bug 2724403]. This code is
      * essentially duplicated in TclTeardownNamespace() for all other
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 507f8b5..c51a69c 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.31 2010/02/11 09:00:55 dkf Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.32 2010/02/15 11:53:45 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -90,6 +90,7 @@ 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		SquelchedNsFirst(ClientData clientData);
 
 static int		PublicObjectCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
@@ -518,6 +519,14 @@ AllocObject(
     ((Namespace *) oPtr->namespacePtr)->flags |= NS_SUPPRESS_COMPILATION;
 
     /*
+     * Set up a callback to get notification of the deletion of a namespace
+     * when enough of the namespace still remains to execute commands and
+     * access variables in it. [Bug 2950259]
+     */
+
+    ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = SquelchedNsFirst;
+
+    /*
      * Fill in the rest of the non-zero/NULL parts of the structure.
      */
 
@@ -616,6 +625,30 @@ MyDeleted(
 /*
  * ----------------------------------------------------------------------
  *
+ * SquelchedNsFirst --
+ *
+ *	This callback is triggered when the object's namespace is deleted by
+ *	any mechanism. It deletes the object's public command if it has not
+ *	already been deleted, so ensuring that destructors get run at an
+ *	appropriate time. [Bug 2950259]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+SquelchedNsFirst(
+    ClientData clientData)
+{
+    Object *oPtr = clientData;
+
+    if (oPtr->command) {
+	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * ObjectRenamedTrace --
  *
  *	This callback is triggered when the object is deleted by any
@@ -697,6 +730,9 @@ ObjectRenamedTrace(
      * OK, the destructor's been run. Time to splat the class data (if any)
      * 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]
      */
 
     clsPtr = oPtr->classPtr;
@@ -704,7 +740,9 @@ ObjectRenamedTrace(
 	AddRef(clsPtr);
 	ReleaseClassContents(interp, oPtr);
     }
-    Tcl_DeleteNamespace(oPtr->namespacePtr);
+    if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
+	Tcl_DeleteNamespace(oPtr->namespacePtr);
+    }
     if (clsPtr) {
 	DelRef(clsPtr);
     }