From 8a4b2ce65944b09d87fb02f51dc1ac2346ac9c72 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 4 Mar 2010 23:42:52 +0000 Subject: Fix [Bug 2962664] by forcing oo::object deletion on oo::class deletion. --- ChangeLog | 51 ++++++++++++++++++++++++++++------------------- generic/tclOO.c | 30 ++++++++++++++++++++++------ generic/tclOODefineCmds.c | 10 +++++----- generic/tclOOInt.h | 6 +++++- tests/oo.test | 26 +++++++++++++++++++++++- 5 files changed, 89 insertions(+), 34 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2c9b6f8..90a0375 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,36 +1,45 @@ +2010-03-04 Donal K. Fellows + + * generic/tclOO.c (ObjectRenamedTrace): Add special handling so that + when the class of classes is deleted, so is the class of objects. + Immediately. [Bug 2962664] + + * generic/tclOOInt.h (ROOT_CLASS): Add new flag for specially marking + the root class. Simpler than the + 2010-03-04 Jan Nijtmans - * generic/tclGetDate.y 3 unnecessary MODULE_SCOPE - * generic/tclDate.c symbols - * generic/tclStubLib.c Split tommath stub lib - * generic/tclTomMathStubLib.c in separate file. - * win/makefile.bc - * win/Makefile.in - * win/makefile.vc - * win/tcl.dsp - * unix/Makefile.in - * unix/tcl.m4 Cygwin only gives warning - * unix/configure using -fvisibility=hidden - * compat/strncasecmp.c A few more const's - * compat/strtod.c - * compat/strtoul.c + * generic/tclGetDate.y: 3 unnecessary MODULE_SCOPE + * generic/tclDate.c: symbols + * generic/tclStubLib.c: Split tommath stub lib + * generic/tclTomMathStubLib.c: in separate file. + * win/makefile.bc: + * win/Makefile.in: + * win/makefile.vc: + * win/tcl.dsp: + * unix/Makefile.in: + * unix/tcl.m4: Cygwin only gives warning + * unix/configure: using -fvisibility=hidden + * compat/strncasecmp.c: A few more const's + * compat/strtod.c: + * compat/strtoul.c: 2010-03-03 Andreas Kupries * doc/refchan.n: Followup to ChangeLog entry 2009-10-07 - (generic/tclIORChan.c). Fixed the documentation to explain that - errno numbers are operating system dependent, and reworked the - associated example. + (generic/tclIORChan.c). Fixed the documentation to explain that errno + numbers are operating system dependent, and reworked the associated + example. 2010-03-02 Jan Nijtmans - * unix/tcl.m4 [Enh 2959069] Support for -fvisibility=hidden - * unix/configure (regenerated with autoconf-2.59) + * unix/tcl.m4: [FRQ 2959069]: Support for -fvisibility=hidden + * unix/configure (regenerated with autoconf-2.59) 2010-03-01 Alexandre Ferrieux - * unix/tclUnixSock.c: Refrain from a possibly lengthy reverse-DNS - lookup on 0.0.0.0 when calling [fconfigure -sockname] on an + * unix/tclUnixSock.c: Refrain from a possibly lengthy reverse-DNS + lookup on 0.0.0.0 when calling [fconfigure -sockname] on an universally-bound (default) server socket. * generic/tclIndexObj.c: fix [AT 86258]: special-casing of empty 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; } diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 2fb9ce5..ad088af 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.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: tclOODefineCmds.c,v 1.11 2009/05/04 17:39:51 dkf Exp $ + * RCS: @(#) $Id: tclOODefineCmds.c,v 1.12 2010/03/04 23:42:54 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -1043,12 +1043,12 @@ TclOODefineClassObjCmd( if (oPtr == NULL) { return TCL_ERROR; } - if (oPtr == fPtr->objectCls->thisPtr) { + if (oPtr->flags & ROOT_OBJECT) { Tcl_AppendResult(interp, - "may not modify the class of the root object", NULL); + "may not modify the class of the root object class", NULL); return TCL_ERROR; } - if (oPtr == fPtr->classCls->thisPtr) { + if (oPtr->flags & ROOT_CLASS) { Tcl_AppendResult(interp, "may not modify the class of the class of classes", NULL); return TCL_ERROR; @@ -1679,7 +1679,7 @@ TclOODefineSuperclassObjCmd( NULL); return TCL_ERROR; } - if (oPtr == fPtr->objectCls->thisPtr) { + if (oPtr->flags & ROOT_OBJECT) { Tcl_AppendResult(interp, "may not modify the superclass of the root object", NULL); return TCL_ERROR; diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index dc52638..2103dc0 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.15 2010/01/29 16:17:20 nijtmans Exp $ + * RCS: @(#) $Id: tclOOInt.h,v 1.16 2010/03/04 23:42:54 dkf Exp $ */ #ifndef TCL_OO_INTERNAL_H @@ -212,6 +212,10 @@ typedef struct Object { * instance of the class, and has had nothing * added that changes the dispatch chain (i.e. * no methods, mixins, or filters. */ +#define ROOT_CLASS 0x8000 /* Flag to say that this object is the root + * class of classes, and should be treated + * specially during teardown (and in a few + * other spots). */ /* * And the definition of a class. Note that every class also has an associated diff --git a/tests/oo.test b/tests/oo.test index fbb8971..adcab4b 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: oo.test,v 1.37 2010/02/15 11:53:45 dkf Exp $ +# RCS: @(#) $Id: oo.test,v 1.38 2010/03/04 23:42:54 dkf Exp $ package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h if {[lsearch [namespace children] ::tcltest] == -1} { @@ -72,6 +72,30 @@ test oo-0.5 {testing literal leak on interp delete} memory { interp delete foo } } 0 +test oo-0.6 {cleaning the core class pair; way #1} -setup { + interp create t + initInterpreter t +} -body { + t eval { + package require TclOO + namespace path oo + list [catch {class destroy} m] $m [catch {object destroy} m] $m + } +} -cleanup { + interp delete t +} -result {0 {} 1 {invalid command name "object"}} +test oo-0.7 {cleaning the core class pair; way #2} -setup { + interp create t + initInterpreter t +} -body { + t eval { + package require TclOO + namespace path oo + list [catch {object destroy} m] $m [catch {class destroy} m] $m + } +} -cleanup { + interp delete t +} -result {0 {} 1 {invalid command name "class"}} test oo-1.1 {basic test of OO functionality: no classes} { set result {} -- cgit v0.12