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.

1 files changed, 7 insertions, 6 deletions

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;
 }