summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2010-01-28 10:25:03 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2010-01-28 10:25:03 (GMT)
commitcd034550642034bd5b4eabf2e0ea1cd5cf06719c (patch)
tree5b3c218fe68fcb9e058cf40de629094ec43f22d5 /generic
parent3ec5feb3637f136b6c659eb42c52100c41f2e8ca (diff)
downloadtcl-cd034550642034bd5b4eabf2e0ea1cd5cf06719c.zip
tcl-cd034550642034bd5b4eabf2e0ea1cd5cf06719c.tar.gz
tcl-cd034550642034bd5b4eabf2e0ea1cd5cf06719c.tar.bz2
Improvements to destructor handling.
Stop crashes from odd destruction routes.
Diffstat (limited to 'generic')
-rw-r--r--generic/tclOO.c87
-rw-r--r--generic/tclOOBasic.c18
-rw-r--r--generic/tclOOInt.h4
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. */