Plug memory leak. [Bug 2910044]

3 files changed, 80 insertions, 2 deletions

diff --git a/ChangeLog b/ChangeLog
index f33db7e..6262026 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2009-12-07  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCmdMZ.c (TryPostBody): [Bug 2910044]: Close off memory
+	leak in [try] when a variable-free handler clause is present.
+
 2009-12-05  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclBasic.c:   Small changes for clarity in tailcall
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 427bf68..28f4d77 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.196 2009/11/18 21:59:50 nijtmans Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.197 2009/12/07 15:08:47 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -4433,8 +4433,10 @@ TryPostBody(
 		Tcl_ListObjIndex(NULL, info[3], 0, &varName);
 		if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj,
 			TCL_LEAVE_ERR_MSG) == NULL) {
+		    Tcl_DecrRefCount(resultObj);
 		    goto handlerFailed;
 		}
+		Tcl_DecrRefCount(resultObj);
 		if (dummy > 1) {
 		    Tcl_ListObjIndex(NULL, info[3], 1, &varName);
 		    if (Tcl_ObjSetVar2(interp, varName, NULL, options,
@@ -4442,6 +4444,12 @@ TryPostBody(
 			goto handlerFailed;
 		    }
 		}
+	    } else {
+		/*
+		 * Dispose of the result to prevent a memleak. [Bug 2910044]
+		 */
+
+		Tcl_DecrRefCount(resultObj);
 	    }
 
 	    /*
diff --git a/tests/error.test b/tests/error.test
index f522008..8f0c0f0 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -11,14 +11,30 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: error.test,v 1.24 2009/11/16 18:00:11 dgp Exp $
+# RCS: @(#) $Id: error.test,v 1.25 2009/12/07 15:08:47 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
     namespace import -force ::tcltest::*
 }
 
+testConstraint memory [llength [info commands memory]]
 namespace eval ::tcl::test::error {
+if {[testConstraint memory]} {
+    proc getbytes {} {
+	set lines [split [memory info] \n]
+	return [lindex $lines 3 3]
+    }
+    proc leaktest {script {iterations 3}} {
+	set end [getbytes]
+	for {set i 0} {$i < $iterations} {incr i} {
+	    uplevel 1 $script
+	    set tmp $end
+	    set end [getbytes]
+	}
+	return [expr {$end - $tmp}]
+    }
+}
 
 proc foo {} {
     global errorInfo
@@ -801,6 +817,55 @@ test error-20.2 {bad code value in on handler} -body {
     try { list a b c } on 34985723094872345 {} {}
 } -returnCodes error -match glob -result {bad code *}
 
+test error-21.1 {memory leaks in try: Bug 2910044} memory {
+    leaktest {
+	try {string repeat x 10} on ok {} {}
+    }
+} 0
+test error-21.2 {memory leaks in try: Bug 2910044} memory {
+    leaktest {
+	try {error [string repeat x 10]} on error {} {}
+    }
+} 0
+test error-21.3 {memory leaks in try: Bug 2910044} memory {
+    leaktest {
+	try {throw FOO [string repeat x 10]} trap FOO {} {}
+    }
+} 0
+test error-21.4 {memory leaks in try: Bug 2910044} memory {
+    leaktest {
+	try {string repeat x 10}
+    }
+} 0
+test error-21.5 {memory leaks in try: Bug 2910044} memory {
+    leaktest {
+	try {string repeat x 10} on ok {} {} finally {string repeat y 10}
+    }
+} 0
+test error-21.6 {memory leaks in try: Bug 2910044} memory {
+    leaktest {
+	try {
+	    error [string repeat x 10]
+	} on error {} {} finally {
+	    string repeat y 10
+	}
+    }
+} 0
+test error-21.7 {memory leaks in try: Bug 2910044} memory {
+    leaktest {
+	try {
+	    throw FOO [string repeat x 10]
+	} trap FOO {} {} finally {
+	    string repeat y 10
+	}
+    }
+} 0
+test error-21.8 {memory leaks in try: Bug 2910044} memory {
+    leaktest {
+	try {string repeat x 10} finally {string repeat y 10}
+    }
+} 0
+
 # negative case try tests - bad "trap" handler
 # what is the effect if we attempt to trap an errorcode that is not a list?
 # nested try