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.

diff --git a/embed.fnc b/embed.fnc
index dd48aa0..152a2a7 100644 (file)
--- 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 0a3c7fa..a2138ec 100644 (file)
--- 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 c27e338..7dc9021 100644 (file)
--- 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 057af94..5685639 100644 (file)
--- 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 843cf50..314db98 100644 (file)
--- 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 26df2aa..dd20288 100644 (file)
--- 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 1b29739..46f5742 100644 (file)
--- 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 496f753..b4fd4dd 100644 (file)
--- 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 f06e4e3..9820601 100644 (file)
--- 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 4a46796..2370a4b 100644 (file)
--- 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 86b8c7f..9985ba9 100644 (file)
--- 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;
 }