Fix format closure bug with redefined outer sub

CVs close over their outer CVs.  So, when you write:

my $x = 52;
sub foo {
  sub bar {
    sub baz {
      $x
    }
  }
}

baz’s CvOUTSIDE pointer points to bar, bar’s CvOUTSIDE points to foo,
and foo’s to the main cv.

When the inner reference to $x is looked up, the CvOUTSIDE chain is
followed, and each sub’s pad is looked at to see if it has an $x.
(This happens at compile time.)

It can happen that bar is undefined and then redefined:

undef &bar;
eval 'sub bar { my $x = 34 }';

After this, baz will still refer to the main cv’s $x (52), but, if baz
had  ‘eval '$x'’ instead of just $x, it would see the new bar’s $x.
(It’s not really a new bar, as its refaddr is the same, but it has a
new body.)

This particular case is harmless, and is obscure enough that we could
define it any way we want, and it could still be considered correct.

The real problem happens when CVs are cloned.

When a CV is cloned, its name pad already contains the offsets into
the parent pad where the values are to be found.  If the outer CV
has been undefined and redefined, those pad offsets can be com-
pletely bogus.

Normally, a CV cannot be cloned except when its outer CV is running.
And the outer CV cannot have been undefined without also throwing
away the op that would have cloned the prototype.

But formats can be cloned when the outer CV is not running.  So it
is possible for cloned formats to close over bogus entries in a new
parent pad.

In this example, \$x gives us an array ref.  It shows ARRAY(0xbaff1ed)
instead of SCALAR(0xdeafbee):

sub foo {
    my $x;
format =
@
($x,warn \$x)[0]
.
}
undef &foo;
eval 'sub foo { my @x; write }';
foo
__END__

And if the offset that the format’s pad closes over is beyond the end
of the parent’s new pad, we can even get a crash, as in this case:

eval
'sub foo {' .
'{my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}'x999
. q|
    my $x;
format =
@
($x,warn \$x)[0]
.
}
|;
undef &foo;
eval 'sub foo { my @x; my $x = 34; write }';
foo();
__END__

So now, instead of using CvROOT to identify clones of
CvOUTSIDE(format), we use the padlist ID instead.  Padlists don’t
actually have an ID, so we give them one.  Any time a sub is cloned,
the new padlist gets the same ID as the old.  The format needs to
remember what its outer sub’s padlist ID was, so we put that in the
padlist struct, too.

11 files changed, 46 insertions, 22 deletions

diff --git a/embed.fnc b/embed.fnc
index dd48aa0f15..152a2a7ff3 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2346,7 +2346,7 @@ p	|PAD **	|padlist_store	|NN PADLIST *padlist|I32 key \
 				|NULLOK PAD *val
 
 ApdR	|CV*	|find_runcv	|NULLOK U32 *db_seqp
-pR	|CV*	|find_runcv_where|U8 cond|NULLOK void *arg \
+pR	|CV*	|find_runcv_where|U8 cond|IV arg \
 				 |NULLOK U32 *db_seqp
 : Only used in perl.c
 p	|void	|free_tied_hv_pool
diff --git a/embedvar.h b/embedvar.h
index 0a3c7fa2d9..a2138ecdae 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -255,6 +255,7 @@
 #define PL_pad_reset_pending	(vTHX->Ipad_reset_pending)
 #define PL_padix		(vTHX->Ipadix)
 #define PL_padix_floor		(vTHX->Ipadix_floor)
+#define PL_padlist_generation	(vTHX->Ipadlist_generation)
 #define PL_parser		(vTHX->Iparser)
 #define PL_patchlevel		(vTHX->Ipatchlevel)
 #define PL_peepp		(vTHX->Ipeepp)
diff --git a/intrpvar.h b/intrpvar.h
index c27e33893f..7dc9021adf 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -778,6 +778,7 @@ PERLVAR(I, custom_ops,	HV *)		/* custom op registrations */
 PERLVARI(I, globhook,	globhook_t, NULL)
 
 PERLVARI(I, glob_index,	int,	0)
+PERLVARI(I, padlist_generation, U32, 1)	/* id to identify padlist clones */
 PERLVAR(I, reentrant_retint, int)	/* Integer return value from reentrant functions */
 
 /* The last unconditional member of the interpreter structure when 5.10.0 was
diff --git a/pad.c b/pad.c
index 057af94544..56856399f3 100644
--- a/pad.c
+++ b/pad.c
@@ -276,6 +276,7 @@ Perl_pad_new(pTHX_ int flags)
 	AvREIFY_only(a0);
     }
     else {
+	padlist->xpadl_id = PL_padlist_generation++;
 	av_store(pad, 0, NULL);
     }
 
@@ -1966,18 +1967,20 @@ Perl_cv_clone(pTHX_ CV *proto)
 	outside = find_runcv(NULL);
     else {
 	outside = CvOUTSIDE(proto);
-	if (CvCLONE(outside) && ! CvCLONED(outside)) {
-	    CV * const runcv = find_runcv_where(
-		FIND_RUNCV_root_eq, (void *)CvROOT(outside), NULL
+	if ((CvCLONE(outside) && ! CvCLONED(outside))
+	    || !CvPADLIST(outside)
+	    || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
+	    outside = find_runcv_where(
+		FIND_RUNCV_padid_eq, (IV)protopadlist->xpadl_outid, NULL
 	    );
-	    if (runcv) outside = runcv;
+	    /* outside could be null */
 	}
     }
-    depth = CvDEPTH(outside);
+    depth = outside ? CvDEPTH(outside) : 0;
     assert(depth || SvTYPE(proto) == SVt_PVFM);
     if (!depth)
 	depth = 1;
-    assert(CvPADLIST(outside) || SvTYPE(proto) == SVt_PVFM);
+    assert(SvTYPE(proto) == SVt_PVFM || CvPADLIST(outside));
 
     ENTER;
     SAVESPTR(PL_compcv);
@@ -2005,6 +2008,7 @@ Perl_cv_clone(pTHX_ CV *proto)
 	mg_copy((SV *)proto, (SV *)cv, 0, 0);
 
     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
+    CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
 
     av_fill(PL_comppad, fpad);
     for (ix = fname; ix > 0; ix--)
@@ -2012,10 +2016,11 @@ Perl_cv_clone(pTHX_ CV *proto)
 
     PL_curpad = AvARRAY(PL_comppad);
 
-    outpad = CvPADLIST(outside)
+    outpad = outside && CvPADLIST(outside)
 	? AvARRAY(PADLIST_ARRAY(CvPADLIST(outside))[depth])
 	: NULL;
     assert(outpad || SvTYPE(cv) == SVt_PVFM);
+    if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
 
     for (ix = fpad; ix > 0; ix--) {
 	SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
@@ -2026,7 +2031,7 @@ Perl_cv_clone(pTHX_ CV *proto)
 		   but state vars are always available. */
 		if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
 		 || (  SvPADSTALE(sv) && !SvPAD_STATE(namesv)
-		    && !CvDEPTH(outside))  ) {
+		    && (!outside || !CvDEPTH(outside)))  ) {
 		    assert(SvTYPE(cv) == SVt_PVFM);
 		    Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
 				   "Variable \"%"SVf"\" is not available", namesv);
@@ -2063,7 +2068,7 @@ Perl_cv_clone(pTHX_ CV *proto)
 
     DEBUG_Xv(
 	PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
-	cv_dump(outside, "Outside");
+	if (outside) cv_dump(outside, "Outside");
 	cv_dump(proto,	 "Proto");
 	cv_dump(cv,	 "To");
     );
diff --git a/pad.h b/pad.h
index 843cf50206..314db989be 100644
--- a/pad.h
+++ b/pad.h
@@ -31,6 +31,8 @@ typedef U64TYPE PADOFFSET;
 struct padlist {
     SSize_t	xpadl_max;	/* max index for which array has space */
     PAD **	xpadl_alloc;	/* pointer to beginning of array of AVs */
+    U32		xpadl_id;	/* Semi-unique ID, shared between clones */
+    U32		xpadl_outid;	/* ID of outer pad */
 };
 
 
diff --git a/pp.c b/pp.c
index 26df2aad85..dd202889c6 100644
--- a/pp.c
+++ b/pp.c
@@ -5799,7 +5799,7 @@ PP(pp_coreargs)
 	  try_defsv:
 	    if (!numargs && defgv && whicharg == minargs + 1) {
 		PUSHs(find_rundefsv2(
-		    find_runcv_where(FIND_RUNCV_level_eq, (void *)1, NULL),
+		    find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
 		    cxstack[cxstack_ix].blk_oldcop->cop_seq
 		));
 	    }
@@ -5888,7 +5888,7 @@ PP(pp_runcv)
     dSP;
     CV *cv;
     if (PL_op->op_private & OPpOFFBYONE) {
-	cv = find_runcv_where(FIND_RUNCV_level_eq, (void *)1, NULL);
+	cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
     }
     else cv = find_runcv(NULL);
     XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
diff --git a/pp.h b/pp.h
index 1b29739bb0..46f574271f 100644
--- a/pp.h
+++ b/pp.h
@@ -527,7 +527,7 @@ True if this op will be the return value of an lvalue subroutine
 #  define MAYBE_DEREF_GV(sv)      MAYBE_DEREF_GV_flags(sv,SV_GMAGIC)
 #  define MAYBE_DEREF_GV_nomg(sv) MAYBE_DEREF_GV_flags(sv,0)
 
-#  define FIND_RUNCV_root_eq	1
+#  define FIND_RUNCV_padid_eq	1
 #  define FIND_RUNCV_level_eq	2
 
 #endif
diff --git a/pp_ctl.c b/pp_ctl.c
index 496f753c75..b4fd4dd699 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3227,12 +3227,12 @@ than in the scope of the debugger itself).
 CV*
 Perl_find_runcv(pTHX_ U32 *db_seqp)
 {
-    return Perl_find_runcv_where(aTHX_ 0, NULL, db_seqp);
+    return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
 }
 
 /* If this becomes part of the API, it might need a better name. */
 CV *
-Perl_find_runcv_where(pTHX_ U8 cond, void *arg, U32 *db_seqp)
+Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
 {
     dVAR;
     PERL_SI	 *si;
@@ -3257,11 +3257,12 @@ Perl_find_runcv_where(pTHX_ U8 cond, void *arg, U32 *db_seqp)
 		cv = cx->blk_eval.cv;
 	    if (cv) {
 		switch (cond) {
-		case FIND_RUNCV_root_eq:
-		    if (CvROOT(cv) != (OP *)arg) continue;
+		case FIND_RUNCV_padid_eq:
+		    if (!CvPADLIST(cv)
+		     || CvPADLIST(cv)->xpadl_id != (U32)arg) continue;
 		    return cv;
 		case FIND_RUNCV_level_eq:
-		    if (level++ != PTR2IV(arg)) continue;
+		    if (level++ != arg) continue;
 		    /* GERONIMO! */
 		default:
 		    return cv;
@@ -3269,7 +3270,7 @@ Perl_find_runcv_where(pTHX_ U8 cond, void *arg, U32 *db_seqp)
 	    }
 	}
     }
-    return cond == FIND_RUNCV_root_eq ? NULL : PL_main_cv;
+    return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
 }
 
 
diff --git a/proto.h b/proto.h
index f06e4e3735..9820601dc0 100644
--- a/proto.h
+++ b/proto.h
@@ -1038,7 +1038,7 @@ PERL_CALLCONV void	Perl_finalize_optree(pTHX_ OP* o)
 PERL_CALLCONV CV*	Perl_find_runcv(pTHX_ U32 *db_seqp)
 			__attribute__warn_unused_result__;
 
-PERL_CALLCONV CV*	Perl_find_runcv_where(pTHX_ U8 cond, void *arg, U32 *db_seqp)
+PERL_CALLCONV CV*	Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
 			__attribute__warn_unused_result__;
 
 PERL_CALLCONV SV*	Perl_find_rundefsv(pTHX);
diff --git a/t/comp/form_scope.t b/t/comp/form_scope.t
index 4a46796fb2..2370a4bb30 100644
--- a/t/comp/form_scope.t
+++ b/t/comp/form_scope.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..13\n";
+print "1..14\n";
 
 # Tests bug #22977.  Test case from Dave Mitchell.
 sub f ($);
@@ -133,12 +133,24 @@ do { my $t = "ok " . $testn--; write if $t =~ 12; $t}
 *STDOUT = *STDOUT8{FORMAT};
 write;
 
+sub _13 {
+    my $x;
+format STDOUT13 =
+@* - formats closing over redefined subs
+ref \$x eq 'SCALAR' ? "ok 13" : "not ok 13";
+.
+}
+undef &_13;
+eval 'sub _13 { my @x; write }';
+*STDOUT = *STDOUT13{FORMAT};
+_13();
+
 # This is a variation of bug #22977, which crashes or fails an assertion
 # up to 5.16.
 # Keep this test last if you want test numbers to be sane.
 BEGIN { \&END }
 END {
-  my $test = "ok 13";
+  my $test = "ok 14";
   *STDOUT = *STDOUT5{FORMAT};
   write;
   format STDOUT5 =
diff --git a/toke.c b/toke.c
index 86b8c7fddc..9985ba9db5 100644
--- a/toke.c
+++ b/toke.c
@@ -10853,6 +10853,8 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
     CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
+    if (outsidecv && CvPADLIST(outsidecv))
+	CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
 
     return oldsavestack_ix;
 }