summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog6
-rw-r--r--generic/tclProc.c8
-rw-r--r--tests/apply.test41
3 files changed, 52 insertions, 3 deletions
diff --git a/ChangeLog b/ChangeLog
index a415b95..b5219f2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2006-10-16 Miguel Sofer <msofer@users.sf.net>
+
+ * tclProc.c (SetLambdaFromAny):
+ * tests/apply.test (9.1-9.2): plugged intrep leak [Bug 1578454],
+ found by mjanssen.
+
2006-10-16 Andreas Kupries <andreask@activestate.com>
*** 8.5a5 TAGGED FOR RELEASE ***
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 035de96..d8a959e 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.92 2006/09/30 17:56:47 msofer Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.93 2006/10/16 20:36:19 msofer Exp $
*/
#include "tclInt.h"
@@ -2036,7 +2036,11 @@ SetLambdaFromAny(
Tcl_GetString(objPtr), NULL);
return TCL_ERROR;
}
- procPtr->refCount++;
+
+ /* CAREFUL: TclCreateProc returns refCount==1! [Bug 1578454]
+ * procPtr->refCount = 1;
+ */
+
procPtr->cmdPtr = NULL;
/*
diff --git a/tests/apply.test b/tests/apply.test
index b1769fa..563210c 100644
--- a/tests/apply.test
+++ b/tests/apply.test
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: apply.test,v 1.6 2006/10/09 19:15:41 msofer Exp $
+# RCS: @(#) $Id: apply.test,v 1.7 2006/10/16 20:36:19 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -23,6 +23,8 @@ if {[info commands ::apply] eq {}} {
return
}
+testConstraint memory [llength [info commands memory]]
+
# Tests for wrong number of arguments
test apply-1.1 {too few arguments} {
@@ -261,6 +263,43 @@ test apply-8.10 {default values} {
apply [list {x {y 2} args} $applyBody] 1 3
} {{x 1} {y 3} {args {}}}
+# Tests for leaks
+
+test apply-9.1 {leaking internal rep} -setup {
+ proc getbytes {} {
+ set lines [split [memory info] "\n"]
+ lindex $lines 3 3
+ }
+ set lam [list {} {set a 1}]
+} -constraints memory -body {
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ ::apply [lrange $lam 0 end]
+ set tmp $end
+ set end [getbytes]
+ }
+ set leakedBytes [expr {$end - $tmp}]
+} -cleanup {
+ rename getbytes {}
+ unset lam
+} -result 0
+test apply-9.2 {leaking internal rep} -setup {
+ proc getbytes {} {
+ set lines [split [memory info] "\n"]
+ lindex $lines 3 3
+ }
+} -constraints memory -body {
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ ::apply [list {} {set a 1}]
+ set tmp $end
+ set end [getbytes]
+ }
+ set leakedBytes [expr {$end - $tmp}]
+} -cleanup {
+ rename getbytes {}
+} -result 0
+
# Tests for the avoidance of recompilation
# cleanup