From d21830d6102251026eb770706ba3319f1cc24755 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 31 May 2008 22:29:45 +0000 Subject: Plug method-related memory leaks pointed out by Miguel. --- ChangeLog | 11 +++++++++-- generic/tclOO.c | 31 +++++++++++++++++++++---------- generic/tclOOMethod.c | 4 ++-- tests/oo.test | 9 ++++++++- 4 files changed, 40 insertions(+), 15 deletions(-) diff --git a/ChangeLog b/ChangeLog index 0b12e37..0395762 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,10 +1,17 @@ 2008-05-31 Donal K. Fellows + * generic/tclOO.c (InitFoundation): Correct reference counting for + strings used when creating the constructor for classes. + * generic/tclOOMethod.c (TclOODelMethodRef): Correct fencepost error + in reference counting of method implementation structures. + * tests/oo.test (oo-0.5): Added a test to detect a memory leak problem + relating to disposal of the core object system. + TIP#257 IMPLEMENTATION * generic/tclBasic.c, generic/tclOOInt.h: Correct declarations. - * win/Makefile.in, win/makefile.bc, win/makefile.vc: Build support - for Win32, from Joe Mistachkin. [Patch 1980861] + * win/Makefile.in, win/makefile.bc, win/makefile.vc: Build support for + Win32, from Joe Mistachkin. [Patch 1980861] * generic/tclOO*, doc/*, tests/oo.test: Port of implementation of TclOO to sit directly inside Tcl. Note that this is incomplete (e.g. diff --git a/generic/tclOO.c b/generic/tclOO.c index de0b36b..73b1034 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.4 2008/05/31 11:42:16 dkf Exp $ + * RCS: @(#) $Id: tclOO.c,v 1.5 2008/05/31 22:29:45 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -276,6 +276,8 @@ InitFoundation( fPtr->classCls->thisPtr->selfCls = fPtr->classCls; TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); + AddRef(fPtr->objectCls->thisPtr); + AddRef(fPtr->objectCls); /* * Basic method declarations for the core classes. @@ -299,6 +301,7 @@ InitFoundation( namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL); argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1); + Tcl_IncrRefCount(argsPtr); bodyPtr = Tcl_NewStringObj( "if {[catch {define [self] $definitionScript} msg opt]} {\n" "set ei [split [dict get $opt -errorinfo] \\n]\n" @@ -308,6 +311,7 @@ InitFoundation( "return -options $opt $msg", -1); fPtr->classCls->constructorPtr = TclOONewProcMethod(interp, fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL); + Tcl_DecrRefCount(argsPtr); /* * Create non-object commands and plug ourselves into the Tcl [info] @@ -346,6 +350,8 @@ KillFoundation( { Foundation *fPtr = GetFoundation(interp); + DelRef(fPtr->objectCls->thisPtr); + DelRef(fPtr->objectCls); Tcl_DecrRefCount(fPtr->unknownMethodNameObj); Tcl_DecrRefCount(fPtr->constructorName); Tcl_DecrRefCount(fPtr->destructorName); @@ -472,7 +478,7 @@ AllocObject( /* * Access the namespace command table directly when creating "my" to avoid - * a bottleneck in string manipulation. + * a bottleneck in string manipulation. */ { @@ -541,7 +547,7 @@ ObjectRenamedTrace( AddRef(oPtr); oPtr->flags |= OBJECT_DELETED; - if (!Tcl_InterpDeleted(interp)) { + if (!(flags & TCL_INTERP_DESTROYED)) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR); if (contextPtr != NULL) { @@ -613,7 +619,8 @@ ReleaseClassContents( AddRef(list[i]); } for (i=0 ; iflags & OBJECT_DELETED) && interp != NULL) { + if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) { + list[i]->thisPtr->flags |= OBJECT_DELETED; Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command); } DelRef(list[i]); @@ -631,7 +638,8 @@ ReleaseClassContents( AddRef(list[i]); } for (i=0 ; iflags & OBJECT_DELETED) && interp != NULL) { + if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) { + list[i]->thisPtr->flags |= OBJECT_DELETED; Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command); } DelRef(list[i]); @@ -649,7 +657,8 @@ ReleaseClassContents( AddRef(insts[i]); } for (i=0 ; iflags & OBJECT_DELETED) && interp != NULL) { + if (!(insts[i]->flags & OBJECT_DELETED)) { + insts[i]->flags |= OBJECT_DELETED; Tcl_DeleteCommandFromToken(interp, insts[i]->command); } DelRef(insts[i]); @@ -660,9 +669,11 @@ ReleaseClassContents( if (clsPtr->constructorChainPtr) { TclOODeleteChain(clsPtr->constructorChainPtr); + clsPtr->constructorChainPtr = NULL; } if (clsPtr->destructorChainPtr) { TclOODeleteChain(clsPtr->destructorChainPtr); + clsPtr->destructorChainPtr = NULL; } if (clsPtr->classChainCache) { FOREACH_HASH_DECLS; @@ -673,6 +684,7 @@ ReleaseClassContents( } Tcl_DeleteHashTable(clsPtr->classChainCache); ckfree((char *) clsPtr->classChainCache); + clsPtr->classChainCache = NULL; } if (clsPtr->filters.num) { @@ -790,7 +802,7 @@ ObjectNamespaceDeleted( oPtr->metadataPtr = NULL; } - if (clsPtr != NULL && !(oPtr->flags & ROOT_OBJECT)) { + if (clsPtr != NULL) { Class *superPtr, *mixinPtr; if (clsPtr->metadataPtr != NULL) { @@ -806,7 +818,6 @@ ObjectNamespaceDeleted( clsPtr->metadataPtr = NULL; } - clsPtr->flags |= OBJECT_DELETED; FOREACH(filterObj, clsPtr->filters) { Tcl_DecrRefCount(filterObj); } @@ -815,7 +826,7 @@ ObjectNamespaceDeleted( clsPtr->filters.num = 0; } FOREACH(mixinPtr, clsPtr->mixins) { - if (!(mixinPtr->flags & OBJECT_DELETED)) { + if (!(mixinPtr->thisPtr->flags & OBJECT_DELETED)) { TclOORemoveFromMixinSubs(clsPtr, mixinPtr); } } @@ -824,7 +835,7 @@ ObjectNamespaceDeleted( clsPtr->mixins.num = 0; } FOREACH(superPtr, clsPtr->superclasses) { - if (!(superPtr->flags & OBJECT_DELETED)) { + if (!(superPtr->thisPtr->flags & OBJECT_DELETED)) { TclOORemoveFromSubclasses(clsPtr, superPtr); } } diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index f190533..21e0869 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.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: tclOOMethod.c,v 1.1 2008/05/31 11:42:19 dkf Exp $ + * RCS: @(#) $Id: tclOOMethod.c,v 1.2 2008/05/31 22:29:46 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -235,7 +235,7 @@ void TclOODelMethodRef( Method *mPtr) { - if ((mPtr != NULL) && (--mPtr->refCount < 0)) { + if ((mPtr != NULL) && (--mPtr->refCount <= 0)) { if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { mPtr->typePtr->deleteProc(mPtr->clientData); } diff --git a/tests/oo.test b/tests/oo.test index 087e786..a569b77 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.4 2008/05/31 11:42:20 dkf Exp $ +# RCS: @(#) $Id: oo.test,v 1.5 2008/05/31 22:29:46 dkf Exp $ package require TclOO 0.4 ;# Must match value in configure.in if {[lsearch [namespace children] ::tcltest] == -1} { @@ -65,6 +65,13 @@ test oo-0.4 {basic test of OO's ability to clean up its initial state} -body { foo destroy } } -constraints memory -result 0 +test oo-0.5 {testing literal leak on interp delete} memory { + leaktest { + interp create foo + foo eval {oo::object new} + interp delete foo + } +} 0 test oo-1.1 {basic test of OO functionality: no classes} { set result {} -- cgit v0.12