summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2008-05-31 22:29:45 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2008-05-31 22:29:45 (GMT)
commitd21830d6102251026eb770706ba3319f1cc24755 (patch)
tree6fb5a6887947a5210915f6a1c4699289863db712
parentd4816fa0c5eb1cea8d0e924c3187887e2c96cd11 (diff)
downloadtcl-d21830d6102251026eb770706ba3319f1cc24755.zip
tcl-d21830d6102251026eb770706ba3319f1cc24755.tar.gz
tcl-d21830d6102251026eb770706ba3319f1cc24755.tar.bz2
Plug method-related memory leaks pointed out by Miguel.
-rw-r--r--ChangeLog11
-rw-r--r--generic/tclOO.c31
-rw-r--r--generic/tclOOMethod.c4
-rw-r--r--tests/oo.test9
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 {}