diff options
Diffstat (limited to 'generic/tclOO.c')
| -rw-r--r-- | generic/tclOO.c | 30 |
1 files changed, 24 insertions, 6 deletions
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; } |