Improvements to destructor handling.

Stop crashes from odd destruction routes.

3 files changed, 91 insertions, 18 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 242496f..a428aba 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.26 2009/11/24 12:00:08 dkf Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.27 2010/01/28 10:25:04 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -84,6 +84,9 @@ static int		FinalizeObjectCall(ClientData data[],
 static void		InitFoundation(Tcl_Interp *interp);
 static void		KillFoundation(ClientData clientData,
 			    Tcl_Interp *interp);
+static void		MyDeletedTrace(ClientData clientData,
+			    Tcl_Interp *interp, const char *oldName,
+			    const char *newName, int flags);
 static void		ObjectNamespaceDeleted(ClientData clientData);
 static void		ObjectRenamedTrace(ClientData clientData,
 			    Tcl_Interp *interp, const char *oldName,
@@ -558,6 +561,7 @@ AllocObject(
 
     {
 	register Command *cmdPtr = (Command *) ckalloc(sizeof(Command));
+	register CommandTrace *tracePtr;
 
 	memset(cmdPtr, 0, sizeof(Command));
 	cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr;
@@ -570,6 +574,14 @@ AllocObject(
 	cmdPtr->clientData = cmdPtr;
 	cmdPtr->nreProc = PrivateNRObjectCmd;
 	Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr);
+	oPtr->myCommand = (Tcl_Command) cmdPtr;
+	cmdPtr->tracePtr = trace = (CommandTrace *)
+		ckalloc(sizeof(CommandTrace));
+	tracePtr->traceProc = MyDeletedTrace;
+	tracePtr->clientData = oPtr;
+	tracePtr->flags = TCL_TRACE_DELETE;
+	tracePtr->nextPtr = NULL;
+	tracePtr->refCount = 1;
     }
 
     Tcl_TraceCommand(interp, TclGetString(TclOOObjectName(interp, oPtr)),
@@ -581,6 +593,33 @@ AllocObject(
 /*
  * ----------------------------------------------------------------------
  *
+ * MyDeletedTrace --
+ *
+ *	This callback is triggered when the object's [my] command is deleted
+ *	by any mechanism. It just marks the object as not having a [my]
+ *	command, and so prevents cleanup of that when the object itself is
+ *	deleted.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+MyDeletedTrace(
+    ClientData clientData,	/* Reference to the object whose [my] has been
+				 * squelched. */
+    Tcl_Interp *interp,		/* ignored */
+    const char *oldName,	/* ignored */
+    const char *newName,	/* ignored */
+    int flags)			/* ignored */
+{
+    register Object *oPtr = clientData;
+
+    oPtr->myCommand = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * ObjectRenamedTrace --
  *
  *	This callback is triggered when the object is deleted by any
@@ -620,26 +659,35 @@ ObjectRenamedTrace(
      * Oh dear, the object really is being deleted. Handle this by running the
      * destructors and deleting the object's namespace, which in turn causes
      * the real object structures to be deleted.
+     *
+     * Note that it is possible for the namespace to be deleted before the
+     * command. Because of that case, we must take care here to mark the
+     * command as being deleted so that if we return here we don't run into
+     * reentrancy problems.
      */
 
     AddRef(oPtr);
+    oPtr->command = NULL;
     oPtr->flags |= OBJECT_DELETED;
 
-    contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
-    if (contextPtr != NULL) {
-	int result;
-	Tcl_InterpState state;
+    if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
+	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+	oPtr->flags |= DESTRUCTOR_CALLED;
+	if (contextPtr != NULL) {
+	    int result;
+	    Tcl_InterpState state;
 
-	contextPtr->callPtr->flags |= DESTRUCTOR;
-	contextPtr->skip = 0;
-	state = Tcl_SaveInterpState(interp, TCL_OK);
-	result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 0,
-		NULL);
-	if (result != TCL_OK) {
-	    Tcl_BackgroundError(interp);
+	    contextPtr->callPtr->flags |= DESTRUCTOR;
+	    contextPtr->skip = 0;
+	    state = Tcl_SaveInterpState(interp, TCL_OK);
+	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
+		    contextPtr, 0, NULL);
+	    if (result != TCL_OK) {
+		Tcl_BackgroundError(interp);
+	    }
+	    Tcl_RestoreInterpState(interp, state);
+	    TclOODeleteContext(contextPtr);
 	}
-	Tcl_RestoreInterpState(interp, state);
-	TclOODeleteContext(contextPtr);
     }
 
     /*
@@ -819,8 +867,18 @@ ObjectNamespaceDeleted(
 
     /*
      * Instruct everyone to no longer use any allocated fields of the object.
+     * Also delete the commands that refer to the object at this point (if
+     * they still exist) because otherwise their references to the object
+     * point into freed memory, allowing crashes.
      */
 
+    oPtr->flags |= OBJECT_DELETED;
+    if (oPtr->command) {
+	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
+    }
+    if (oPtr->myCommand) {
+	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
+    }
     if (preserved) {
 	AddRef(oPtr);
 	if (clsPtr != NULL) {
@@ -828,7 +886,6 @@ ObjectNamespaceDeleted(
 	    ReleaseClassContents(NULL, oPtr);
 	}
     }
-    oPtr->flags |= OBJECT_DELETED;
 
     /*
      * Splice the object out of its context. After this, we must *not* call
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index e064928..eedbf5a 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.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: tclOOBasic.c,v 1.20 2009/11/27 06:33:40 dkf Exp $
+ * RCS: @(#) $Id: tclOOBasic.c,v 1.21 2010/01/28 10:25:05 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -259,14 +259,28 @@ TclOO_Object_Destroy(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const *objv)	/* The actual arguments. */
 {
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    int result = TCL_OK;
+
     if (objc != Tcl_ObjectContextSkippedArgs(context)) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 		NULL);
 	return TCL_ERROR;
     }
+    if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
+	CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR);
+
+	oPtr->flags |= DESTRUCTOR_CALLED;
+	if (contextPtr != NULL) {
+	    contextPtr->callPtr->flags |= DESTRUCTOR;
+	    contextPtr->skip = 0;
+	    result = TclOOInvokeContext(interp, contextPtr, 0, NULL);
+	    TclOODeleteContext(contextPtr);
+	}
+    }
     Tcl_DeleteCommandFromToken(interp,
 	    Tcl_GetObjectCommand(Tcl_ObjectContextObject(context)));
-    return TCL_OK;
+    return result;
 }
 
 /*
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 86bc9d3..aea18e2 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.13 2009/12/21 23:25:39 nijtmans Exp $
+ * RCS: @(#) $Id: tclOOInt.h,v 1.14 2010/01/28 10:25:05 dkf Exp $
  */
 
 #ifndef TCL_OO_INTERNAL_H
@@ -199,6 +199,8 @@ typedef struct Object {
 
 #define OBJECT_DELETED	1	/* Flag to say that an object has been
 				 * destroyed. */
+#define DESTRUCTOR_CALLED 2	/* Flag to say that the destructor has been
+				 * called. */
 #define ROOT_OBJECT 0x1000	/* Flag to say that this object is the root of
 				 * the class hierarchy and should be treated
 				 * specially during teardown. */