From: Marcus Holland-Moritz <mhx-perl@gmx.net>
Date: Mon, 6 Mar 2006 22:18:52 +0000 (+0000)
Subject: Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=55ef9aae2276249f1bc9d3c71e11acb54457a14a;p=p5sagit%2Fp5-mst-13.2.git

Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
value as we're probably hunting memory leaks then

p4raw-id: //depot/perl@27396
---

diff --git a/perl.c b/perl.c
index d8077d6..11a62e7 100644
--- a/perl.c
+++ b/perl.c
@@ -1289,10 +1289,19 @@ void
 perl_free(pTHXx)
 {
 #ifdef PERL_TRACK_MEMPOOL
-    /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
-       thread at thread exit.  */
-    while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
-	safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+    {
+	/*
+	 * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
+	 * value as we're probably hunting memory leaks then
+	 */
+	const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
+	if (!s || atoi(s) == 0) {
+	    /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
+	       thread at thread exit.  */
+	    while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
+		safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+	}
+    }
 #endif
 
 #if defined(WIN32) || defined(NETWARE)