From: Artur Bergman <sky@nanisky.com>
Date: Fri, 3 Jan 2003 23:45:34 +0000 (+0000)
Subject: Fixes bug #15273, the return of the object caused
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0405e91e9230dfa76b6164c6ed64f7dab29ff49a;p=p5sagit%2Fp5-mst-13.2.git

Fixes bug #15273, the return of the object caused
the stash of the object to be cloned, cloning the entire syntax
tree and all lexicals in there creating danglning copies to the
object. (Pararell but unlinked STASH tree).
This adds a new flag, when set it will use STASHES from the
thread we are joining into avoiding the problem.

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

diff --git a/MANIFEST b/MANIFEST
index cb8ac8e..4e798d4 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -700,6 +700,7 @@ ext/threads/t/end.t		Test end functions
 ext/threads/t/join.t		Testing the join function
 ext/threads/t/libc.t		testing libc functions for threadsafety
 ext/threads/t/list.t		Test threads->list()
+ext/threads/t/problems.t	Test various memory problems
 ext/threads/t/stress_cv.t	Test with multiple threads, coderef cv argument.
 ext/threads/t/stress_re.t	Test with multiple threads, string cv argument and regexes.
 ext/threads/t/stress_string.t	Test with multiple threads, string cv argument.
diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs
index 87abad9..d95e748 100755
--- a/ext/threads/threads.xs
+++ b/ext/threads/threads.xs
@@ -282,12 +282,12 @@ Perl_ithread_run(void * arg) {
 		}
 		PUTBACK;
 		len = call_sv(thread->init_function, thread->gimme|G_EVAL);
+
 		SPAGAIN;
 		for (i=len-1; i >= 0; i--) {
 		  SV *sv = POPs;
 		  av_store(params, i, SvREFCNT_inc(sv));
 		}
-		PUTBACK;
 		if (SvTRUE(ERRSV)) {
 		    Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
 		}
@@ -517,10 +517,27 @@ Perl_ithread_join(pTHX_ SV *obj)
 	  AV* params = (AV*) SvRV(thread->params);	
 	  CLONE_PARAMS clone_params;
 	  clone_params.stashes = newAV();
+	  clone_params.flags |= CLONEf_JOIN_IN;
 	  PL_ptr_table = ptr_table_new();
 	  PERL_THREAD_GETSPECIFIC(self_key,current_thread);
 	  PERL_THREAD_SETSPECIFIC(self_key,thread);
+
+	  {
+	    I32 len = av_len(params)+1;
+	    I32 i;
+	    for(i = 0; i < len; i++) {
+	      //	      sv_dump(SvRV(AvARRAY(params)[i]));
+	    }
+	  }
+
 	  retparam = (AV*) sv_dup((SV*)params, &clone_params);
+	  {
+	    I32 len = av_len(retparam)+1;
+	    I32 i;
+	    for(i = 0; i < len; i++) {
+	      //sv_dump(SvRV(AvARRAY(retparam)[i]));
+	    }
+	  }
 	  PERL_THREAD_SETSPECIFIC(self_key,current_thread);
 	  SvREFCNT_dec(clone_params.stashes);
 	  SvREFCNT_inc(retparam);
diff --git a/sv.c b/sv.c
index e522a47..08eac58 100644
--- a/sv.c
+++ b/sv.c
@@ -9346,6 +9346,18 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
     if (dstr)
 	return dstr;
 
+    if(param->flags & CLONEf_JOIN_IN) {
+        /** We are joining here so we don't want do clone
+	    something that is bad **/
+
+        if(SvTYPE(sstr) == SVt_PVHV &&
+	   HvNAME(sstr)) {
+	    /** don't clone stashes if they already exist **/
+	    HV* old_stash = gv_stashpv(HvNAME(sstr),0);
+	    return (SV*) old_stash;
+        }
+    }
+
     /* create anew and remember what it is */
     new_SV(dstr);
     ptr_table_store(PL_ptr_table, sstr, dstr);
diff --git a/sv.h b/sv.h
index d87ba11..7c5e6dc 100644
--- a/sv.h
+++ b/sv.h
@@ -1186,6 +1186,7 @@ Returns a pointer to the character buffer.
 #define CLONEf_COPY_STACKS 1
 #define CLONEf_KEEP_PTR_TABLE 2
 #define CLONEf_CLONE_HOST 4
+#define CLONEf_JOIN_IN 8
 
 struct clone_params {
   AV* stashes;