Don't clone the contents of lexicals in pads.

This stops the values of lexicals in active stack frames in the parent leaking
into the lexicals in the child thread.

With an exception for lexicals with a reference count of > 1, to cope with the
implementation of ?{{ ... }} blocks in regexps. :-(

diff --git a/pad.c b/pad.c
index 207f475..cc2ade2 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1772,6 +1772,7 @@ Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
 
        I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
        AV *pad1;
+       const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
        const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
        SV **oldpad = AvARRAY(srcpad1);
        SV **names;
@@ -1803,7 +1804,50 @@ Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
            AvFILLp(pad1) = ix;
 
            for ( ;ix > 0; ix--) {
-               pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+               if (!oldpad[ix]) {
+                   pad1a[ix] = NULL;
+               } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
+                   const char sigil = SvPVX_const(names[ix])[0];
+                   if ((SvFLAGS(names[ix]) & SVf_FAKE)
+                       || (SvFLAGS(names[ix]) & SVpad_STATE)
+                       || sigil == '&')
+                       {
+                           /* outer lexical or anon code */
+                           pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+                       }
+                   else {              /* our own lexical */
+                       if(SvREFCNT(oldpad[ix]) > 1) {
+                           pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+                       } else {
+                           SV *sv; 
+                           
+                           if (sigil == '@')
+                               sv = MUTABLE_SV(newAV());
+                           else if (sigil == '%')
+                               sv = MUTABLE_SV(newHV());
+                           else
+                               sv = newSV(0);
+                           pad1a[ix] = sv;
+                           SvPADMY_on(sv);
+                       }
+                   }
+               }
+               else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+                   pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+               }
+               else {
+                   /* save temporaries on recursion? */
+                   SV * const sv = newSV(0);
+                   pad1a[ix] = sv;
+
+                   /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
+                      FIXTHAT before merging this branch.
+                      (And I know how to) */
+                   if (SvPADMY(oldpad[ix]))
+                       SvPADMY_on(sv);
+                   else
+                       SvPADTMP_on(sv);
+               }
            }
 
            if (oldpad[0]) {

diff --git a/t/op/threads.t b/t/op/threads.t
index 95f5776..8fa6025 100644 (file)
--- a/t/op/threads.t
+++ b/t/op/threads.t
@@ -16,7 +16,7 @@ BEGIN {
        exit 0;
      }
 
-     plan(20);
+     plan(21);
 }
 
 use strict;
@@ -257,4 +257,21 @@ fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt neither on tmps stack nor in @_');
     print 'ok';
 EOI
 
+{
+    my $got;
+    sub stuff {
+       my $a;
+       if (@_) {
+           $a = "Leakage";
+           threads->create(\&stuff)->join();
+       } else {
+           is ($a, undef, 'RT #73086 - clone used to clone active pads');
+       }
+    }
+
+    stuff(1);
+
+    curr_test(curr_test() + 1);
+}
+
 # EOF