summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog11
-rw-r--r--generic/tclBasic.c5
-rw-r--r--generic/tclCompile.h3
-rw-r--r--generic/tclNamesp.c26
-rw-r--r--tests/coroutine.test27
-rw-r--r--tests/namespace.test25
6 files changed, 90 insertions, 7 deletions
diff --git a/ChangeLog b/ChangeLog
index d401823..ef0bcdf 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2010-01-03 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclBasic.c: Fix lerak of coroutines on namespace
+ * generic/tclCompile.h: deletion, [Bug 2724403]. Added a test
+ * generic/tclNamesp.c: for this leak, and also a test for
+ * tests/coroutine.test: leaks on namespace deletion.
+ * tests/namespace.test:
+
+ * library/init.tcl (unknown): [Bug 2824981]: Fix infinite recursion of
+ ::unknown when [set] is undefined.
+
2009-12-30 Donal K. Fellows <dkf@users.sf.net>
* library/safe.tcl (AliasSource): [Bug 2923613]: Make the safer
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 43f484b..254760d 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.437 2009/12/24 06:55:25 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.438 2010/01/03 20:29:11 msofer Exp $
*/
#include "tclInt.h"
@@ -137,7 +137,6 @@ static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc,
Tcl_Obj *const objv[], int lookup);
static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
int actual, Tcl_Obj *const *objv);
-static Tcl_ObjCmdProc NRInterpCoroutine;
static Tcl_NRPostProc NRCoroutineCallerCallback;
static Tcl_NRPostProc NRCoroutineExitCallback;
static Tcl_NRPostProc NRRunObjProc;
@@ -8674,7 +8673,7 @@ NRCoroutineExitCallback(
return result;
}
-static int
+int
NRInterpCoroutine(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 25dec86..a41e094 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.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: tclCompile.h,v 1.119 2009/09/04 17:33:11 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.120 2010/01/03 20:29:11 msofer Exp $
*/
#ifndef _TCLCOMPILATION
@@ -858,6 +858,7 @@ typedef struct {
MODULE_SCOPE Tcl_NRPostProc NRCallTEBC;
MODULE_SCOPE Tcl_NRPostProc NRCommand;
+MODULE_SCOPE Tcl_ObjCmdProc NRInterpCoroutine;
#define TCL_NR_BC_TYPE 0
#define TCL_NR_ATEXIT_TYPE 1
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 507007d..f8ee460 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -23,7 +23,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.198 2009/12/13 17:11:47 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.199 2010/01/03 20:29:11 msofer Exp $
*/
#include "tclInt.h"
@@ -956,7 +956,31 @@ Tcl_DeleteNamespace(
Namespace *globalNsPtr = (Namespace *)
TclGetGlobalNamespace((Tcl_Interp *) iPtr);
Tcl_HashEntry *entryPtr;
+ Tcl_HashSearch search;
+ Command *cmdPtr;
+
+ /*
+ * Delete all coroutine commands now: break the circular ref cycle between
+ * the namespace and the coroutine command [Bug 2724403]. This code is
+ * essentially duplicated in TclTeardownNamespace() for all other
+ * commands. Don't optimize to Tcl_NextHashEntry() because of traces.
+ *
+ * NOTE: we could avoid traversing the ns's command list by keeping a
+ * separate list of coros.
+ */
+ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
+ entryPtr != NULL;) {
+ cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ if (cmdPtr->nreProc == NRInterpCoroutine) {
+ Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, (Tcl_Command)cmdPtr);
+ entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
+ } else {
+ entryPtr = entryPtr->nextPtr;
+ }
+ }
+
+
/*
* If the namespace has associated ensemble commands, delete them first.
* This leaves the actual contents of the namespace alone (unless they are
diff --git a/tests/coroutine.test b/tests/coroutine.test
index b4019d4..caa1d0a 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -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: coroutine.test,v 1.10 2009/12/19 14:22:00 msofer Exp $
+# RCS: @(#) $Id: coroutine.test,v 1.11 2010/01/03 20:29:12 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -17,6 +17,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
+testConstraint memory [llength [info commands memory]]
set lambda [list {{start 0} {stop 10}} {
# init
@@ -378,6 +379,7 @@ test coroutine-4.2 {bug #2093188} -setup {
rename bar {}
unset ::res
} -result {{} 3 {{v {} read} {v {} unset}}}
+
test coroutine-4.3 {bug #2093947} -setup {
proc foo {} {
set v 1
@@ -412,6 +414,29 @@ test coroutine-4.4 {bug #2917627: cmd resolution} -setup {
namespace delete b
} -result local
+test coroutine-4.5 {bug #2724403} -constraints {memory} \
+-setup {
+ proc getbytes {} {
+ set lines [split [memory info] "\n"]
+ lindex $lines 3 3
+ }
+} -body {
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ set ns ::y$i
+ namespace eval $ns {}
+ proc ${ns}::start {} {yield; puts hello}
+ coroutine ${ns}::run ${ns}::start
+ namespace delete $ns
+ set start $end
+ set end [getbytes]
+ }
+ set leakedBytes [expr {$end - $start}]
+} -cleanup {
+ rename getbytes {}
+ unset i ns start end
+} -result 0
+
test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} \
-setup {
proc nestedYield {{val {}}} {
diff --git a/tests/namespace.test b/tests/namespace.test
index 5feaf91..889f945 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -11,13 +11,15 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: namespace.test,v 1.76 2009/01/09 15:00:27 dkf Exp $
+# RCS: @(#) $Id: namespace.test,v 1.77 2010/01/03 20:29:12 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
+testConstraint memory [llength [info commands memory]]
+
#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
# found in the file 'upvar.test'.
@@ -2853,6 +2855,27 @@ test namespace-53.10 {ensembles: nested rewrite} -setup {
1 {wrong # args: should be "ns v x z2 a2"}\
0 {2 v v2}}
+test namespace-54.1 {leak on namespace deletion} -constraints {memory} \
+-setup {
+ proc getbytes {} {
+ set lines [split [memory info] "\n"]
+ lindex $lines 3 3
+ }
+} -body {
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ set ns ::y$i
+ namespace eval $ns {}
+ namespace delete $ns
+ set start $end
+ set end [getbytes]
+ }
+ set leakedBytes [expr {$end - $start}]
+} -cleanup {
+ rename getbytes {}
+ unset i ns start end
+} -result 0
+
# cleanup
catch {rename cmd1 {}}
catch {unset l}