From: Artur Bergman <sky@nanisky.com>
Date: Sat, 1 Feb 2003 21:04:36 +0000 (+0000)
Subject: Fix bug #15837, temporary from storable call hadn't gotten
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3b1c327365c3ef67a4c31617c95680c19a00f118;p=p5sagit%2Fp5-mst-13.2.git

Fix bug #15837, temporary from storable call hadn't gotten
freed yet and was cloned but without a real (AvREAL)
reference to it. @_ doesn't refcount!

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

diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs
index c9c2063..68cb699 100755
--- a/ext/threads/threads.xs
+++ b/ext/threads/threads.xs
@@ -129,7 +129,13 @@ Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
 	    PERL_SET_CONTEXT(thread->interp);
 	    PERL_THREAD_GETSPECIFIC(self_key,current_thread);
 	    PERL_THREAD_SETSPECIFIC(self_key,thread);
+
+
+	    
 	    SvREFCNT_dec(thread->params);
+
+
+
 	    thread->params = Nullsv;
 	    perl_destruct(thread->interp);
             perl_free(thread->interp);
@@ -362,6 +368,10 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
 	ithread*	thread;
 	CLONE_PARAMS	clone_param;
 	ithread*        current_thread;
+
+	SV**            tmps_tmp = PL_tmps_stack;
+	I32             tmps_ix  = PL_tmps_ix;
+
 	PERL_THREAD_GETSPECIFIC(self_key,current_thread);
 	MUTEX_LOCK(&create_destruct_mutex);
 	thread = PerlMemShared_malloc(sizeof(ithread));
@@ -384,6 +394,9 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
 
 	PerlIO_flush((PerlIO*)NULL);
 	PERL_THREAD_SETSPECIFIC(self_key,thread);
+
+
+
 #ifdef WIN32
 	thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
 #else
@@ -406,9 +419,42 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
 	    if (SvREFCNT(thread->init_function) == 0) {
 		SvREFCNT_inc(thread->init_function);
 	    }
+	    
+
 
 	    thread->params = sv_dup(params, &clone_param);
 	    SvREFCNT_inc(thread->params);
+
+
+	    /* The code below checks that anything living on
+	       the tmps stack and has been cloned (so it lives in the
+	       ptr_table) has a refcount higher than 0
+
+	       If the refcount is 0 it means that a something on the
+	       stack/context was holding a reference to it and
+	       since we init_stacks() in perl_clone that won't get
+	       cleaned and we will get a leaked scalar.
+	       The reason it was cloned was that it lived on the
+	       @_ stack.
+
+	       Example of this can be found in bugreport 15837
+	       where calls in the parameter list end up as a temp
+
+	       One could argue that this fix should be in perl_clone
+	    */
+	       
+
+	    while (tmps_ix > 0) { 
+	      SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
+	      tmps_ix--;
+	      if (sv && SvREFCNT(sv) == 0) {
+		SvREFCNT_inc(sv);
+		SvREFCNT_dec(sv);
+	      }
+	    }
+	    
+
+
 	    SvTEMP_off(thread->init_function);
 	    ptr_table_free(PL_ptr_table);
 	    PL_ptr_table = NULL;
@@ -452,6 +498,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
 	active_threads++;
 	MUTEX_UNLOCK(&create_destruct_mutex);
 	sv_2mortal(params);
+
 	return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
 }