diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclOO.c | 87 | ||||
| -rw-r--r-- | generic/tclOOBasic.c | 18 | ||||
| -rw-r--r-- | generic/tclOOInt.h | 4 |
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. */ |