Don’t let formats outlive their outer subs

This began crashing in 5.11.3:

sub foo {
  sub bar {
    my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$x);
    format =
@||||||
$x
.
  }
}
undef *bar;
write;

(On some systems, you need more alphabet soup to make it crash.)

This commit (just the perly.y part shown) caused it to crash:

commit 421f30ed1e95009450bdc7905bf3433ee806ea4f
Author: Zefram <zefram@fysh.org>
Date:   Tue Dec 15 11:48:31 2009 +0100

    [perl #22977] Bug in format/write

diff --git a/perly.y b/perly.y
index 18e5875..a61a6b3 100644
--- a/perly.y
+++ b/perly.y
@@ -511,7 +511,9 @@ peg	:	PEG
 	;

 format	:	FORMAT startformsub formname block
-			{ SvREFCNT_inc_simple_void(PL_compcv);
+			{
+			  CV *fmtcv = PL_compcv;
+			  SvREFCNT_inc_simple_void(PL_compcv);
 #ifdef MAD
 			  $$ = newFORM($2, $3, $4);
 			  prepend_madprops($1->tk_mad, $$, 'F');
@@ -521,6 +523,10 @@ format	:	FORMAT startformsub formname block
 			  newFORM($2, $3, $4);
 			  $$ = (OP*)NULL;
 #endif
+			  if (CvOUTSIDE(fmtcv) && !CvUNIQUE(CvOUTSIDE(fmtcv))) {
+			    SvREFCNT_inc_simple_void(fmtcv);
+			    pad_add_anon((SV*)fmtcv, OP_NULL);
+			  }
 			}
 	;

Unfortunately, adding the format to the pad like that (to allow
pad_fixup_inner_anons to fix up formats as well as subs) is proble-
matic.  It causes the format’s CvOUTSIDE to be weak.  Since the for-
mat does not hold a reference count on its outer sub, that sub can be
freed before the format.  When that happens, regular subs are fixed
up by having CvOUTSIDE change to point to the grandparent.  If you
do that for formats, you run into a problem: Formats can be cloned
even when the outer sub is not running.  Formats are cloned whenever
invoked *by name* via write.  If CvOUTSIDE points to a different sub,
then closing over the scalars in specific pad offsets in that sub can
result in reading past the end of the pad.  If you don’t read past the
end of the pad, you are still making variables close over unrelated variables, so the inner $x could close over an outer @y, etc.  Subrou-
tines don’t have that problem, as they can only be cloned when they
have an outer sub.  (Even though the outer sub’s prototype, if it is a
closure, might have been freed, the outer sub itself is still running
and referenced by the context stack.)

This commit changes the direction of the weak reference between an
outer sub’s pad and an inner format, fixing the crash.

To do so, it has to store, not the format itself, but a weak RV point-
ing to the format, in the outer sub’s pad.
(cherry picked from commit e09ac076a1dab8e2c5712775f478fcfb61cb7eb3)

diff --git a/pad.c b/pad.c
index c4362af..1075384 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -400,6 +400,7 @@ Perl_cv_undef(pTHX_ CV *cv)
                        CV * const innercv = MUTABLE_CV(curpad[ix]);
                        U32 inner_rc = SvREFCNT(innercv);
                        assert(inner_rc);
+                       assert(SvTYPE(innercv) != SVt_PVFM);
                        namepad[ix] = NULL;
                        SvREFCNT_dec(namesv);
 
@@ -749,12 +750,19 @@ Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
     ix = pad_alloc(optype, SVs_PADMY);
     av_store(PL_comppad_name, ix, name);
     /* XXX DAPM use PL_curpad[] ? */
-    av_store(PL_comppad, ix, (SV*)func);
+    if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
+       av_store(PL_comppad, ix, (SV*)func);
+    else {
+       SV *rv = newRV_inc((SV *)func);
+       sv_rvweaken(rv);
+       assert (SvTYPE(func) == SVt_PVFM);
+       av_store(PL_comppad, ix, rv);
+    }
     SvPADMY_on((SV*)func);
 
     /* to avoid ref loops, we never have parent + child referencing each
      * other simultaneously */
-    if (CvOUTSIDE(func)) {
+    if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
        assert(!CvWEAKOUTSIDE(func));
        CvWEAKOUTSIDE_on(func);
        SvREFCNT_dec(CvOUTSIDE(func));
@@ -2023,10 +2031,23 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
        if (namesv && namesv != &PL_sv_undef
            && *SvPVX_const(namesv) == '&')
        {
+         if (SvTYPE(curpad[ix]) == SVt_PVCV) {
            CV * const innercv = MUTABLE_CV(curpad[ix]);
            assert(CvWEAKOUTSIDE(innercv));
            assert(CvOUTSIDE(innercv) == old_cv);
            CvOUTSIDE(innercv) = new_cv;
+         }
+         else { /* format reference */
+           SV * const rv = curpad[ix];
+           CV *innercv;
+           if (!SvOK(rv)) continue;
+           assert(SvROK(rv));
+           assert(SvWEAKREF(rv));
+           innercv = (CV *)SvRV(rv);
+           assert(!CvWEAKOUTSIDE(innercv));
+           SvREFCNT_dec(CvOUTSIDE(innercv));
+           CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
+         }
        }
     }
 }

diff --git a/t/comp/form_scope.t b/t/comp/form_scope.t
index 3ef891e..dcd8be9 100644 (file)
--- a/t/comp/form_scope.t
+++ b/t/comp/form_scope.t
@@ -1,9 +1,8 @@
 #!./perl
-#
-# Tests bug #22977.  Test case from Dave Mitchell.
 
-print "1..2\n";
+print "1..3\n";
 
+# Tests bug #22977.  Test case from Dave Mitchell.
 sub f ($);
 sub f ($) {
 my $test = $_[0];
@@ -16,3 +15,38 @@ $test
 
 f(1);
 f(2);
+
+# A bug caused by the fix for #22977/50528
+sub foo {
+  sub bar {
+    # Fill the pad with alphabet soup, to give the closed-over variable a
+    # high padoffset (more likely to trigger the bug and crash).
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
+    my $x;
+    format STDOUT2 =
+@<<<<<<
+"ok 3".$x # $x is not available, but this should not crash
+.
+  }
+}
+*STDOUT = *STDOUT2{FORMAT};
+undef *bar;
+write;
+