From 16c6dd8402ad04f625c0546f3a1715baa928da5f Mon Sep 17 00:00:00 2001
From: Miguel Sofer <miguel.sofer@gmail.com>
Date: Mon, 16 Oct 2006 20:36:19 +0000
Subject: 	* tclProc.c (SetLambdaFromAny): 	* tests/apply.test
 (9.1-9.2): plugged intrep leak [Bug 1578454], 	found by mjanssen.

---
 ChangeLog         |  6 ++++++
 generic/tclProc.c |  8 ++++++--
 tests/apply.test  | 41 ++++++++++++++++++++++++++++++++++++++++-
 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
-- 
cgit v0.12