Plug method-related memory leaks pointed out by Miguel.

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  <dkf@users.sf.net>
 
+	* 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 ; i<n ; i++) {
-	if (!(list[i]->flags & 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 ; i<n ; i++) {
-	if (!(list[i]->flags & 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 ; i<n ; i++) {
-	if (!(insts[i]->flags & 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 {}