Let state sub fwd decls and nested subs work in anons

I had this working:

state sub foo;
sub other {
    sub foo { # defines the state sub declared outside
        ...
    }
}

But it failed inside an anonymous subroutine:

sub {
    state sub foo;
    sub other {
        sub foo { # defines the state sub declared outside
            ...
        }
    }
}

When an anonymous (or otherwise clonable) sub is cloned, any state
vars, and, likewise, any state subs, inside it are cloned, too.

In the first example above the state sub forward declaration creates
a subroutine stub.  The ‘other’ sub’s ‘sub foo’ declaration creates a
pad entry in other’s pad that closes over the outer foo immediately,
so the same stub is visible in two pads.  The sub foo {} declaration
uses that stub.

When the outer sub containing the forward declaration is clonable,
the pad entry is not closed over immediately at compile time, because
the pad entry is just a prototype, not the actual value that will be
shared by the clone and its nested subs.  So the inner pad entry does
not contain the sub.

So the actual creation of the sub, if it only looks at the inner
pad (other’s pad), will not see the stub, and will not attach a
body to it.

This was the result:

$ ./miniperl -e 'CORE::state sub foo; CORE::state sub bar { sub foo {warn called} }; foo()'
called at -e line 1.
$ ./miniperl -e 'sub { CORE::state sub foo; CORE::state sub bar { sub foo {warn called} }; foo() }->()'
Undefined subroutine &foo called at -e line 1.

This commit fixes that by having newMYSUB follow the CvOUTSIDE chain
to find the original pad entry where it defines the sub, if the for-
ward declaration is occurs outside and has not been closed over yet.

diff --git a/op.c b/op.c
index c6566e9..c77b684 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6872,16 +6872,28 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     register CV *compcv = PL_compcv;
     SV *const_sv;
     PADNAME *name;
+    PADOFFSET pax = o->op_targ;
+    CV *outcv = CvOUTSIDE(PL_compcv);
 
     PERL_ARGS_ASSERT_NEWMYSUB;
 
-    /* PL_comppad is the pad owned by the new sub.  We need to look in
-       CvOUTSIDE and find the pad belonging to the enclosing sub, where we
-       store the new one. */
-    name = PadlistNAMESARRAY(CvPADLIST(CvOUTSIDE(PL_compcv)))[o->op_targ];
+    /* Find the pad slot for storing the new sub.
+       We cannot use PL_comppad, as it is the pad owned by the new sub.  We
+       need to look in CvOUTSIDE and find the pad belonging to the enclos-
+       ing sub.  And then we need to dig deeper if this is a lexical from
+       outside, as in:
+          my sub foo; sub { sub foo { } }
+     */
+   redo:
+    name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
+    if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
+       pax = PARENT_PAD_INDEX(name);
+       outcv = CvOUTSIDE(outcv);
+       assert(outcv);
+       goto redo;
+    }
     svspot =
-       &PadARRAY(PadlistARRAY(CvPADLIST(CvOUTSIDE(PL_compcv)))[1])
-           [o->op_targ];
+       &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[1])[pax];
     spot = (CV **)svspot;
 
     if (proto) {
@@ -7020,8 +7032,12 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        PL_compcv = NULL;
        goto done;
     }
-    SvREFCNT_dec(CvOUTSIDE(compcv));
-    CvWEAKOUTSIDE_on(compcv);
+    if (outcv == CvOUTSIDE(compcv)) { 
+       assert(!CvWEAKOUTSIDE(compcv));
+       SvREFCNT_dec(CvOUTSIDE(compcv));
+       CvWEAKOUTSIDE_on(compcv);
+    }
+    /* XXX else do we have a circular reference? */
     if (cv) {  /* must reuse cv in case stub is referenced elsewhere */
        /* transfer PL_compcv to cv */
        if (block
@@ -7032,7 +7048,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
            PADLIST *const temp_padl = CvPADLIST(cv);
            CV *const temp_cv = CvOUTSIDE(cv);
-           const cv_flags_t slabbed = CvSLABBED(cv);
+           const cv_flags_t other_flags =
+               CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
            OP * const cvstart = CvSTART(cv);
 
            assert(CvWEAKOUTSIDE(cv));
@@ -7049,8 +7066,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            CvPADLIST(compcv) = temp_padl;
            CvSTART(cv) = CvSTART(compcv);
            CvSTART(compcv) = cvstart;
-           if (slabbed) CvSLABBED_on(compcv);
-           else CvSLABBED_off(compcv);
+           CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
+           CvFLAGS(compcv) |= other_flags;
 
            if (CvFILE(cv) && CvDYNFILE(cv)) {
                Safefree(CvFILE(cv));

diff --git a/t/cmd/lexsub.t b/t/cmd/lexsub.t
index 157f587..fa4ccdc 100644 (file)
--- a/t/cmd/lexsub.t
+++ b/t/cmd/lexsub.t
@@ -8,7 +8,7 @@ BEGIN {
     *bar::like = *like;
 }
 no warnings 'deprecated';
-plan 104;
+plan 106;
 
 # -------------------- our -------------------- #
 
@@ -155,6 +155,17 @@ is do foo(), 43, 'state sub falling out of scope (called via amper)';
   }
   is eval{sb3}, 47,
     'sub foo{} applying to "state sub foo;" even inside state sub foo{}';
+  # Same test again, but inside an anonymous sub
+  sub {
+    state sub sb4;
+    {
+      state sub sb4 {
+        sub sb4 { 47 }
+      }
+    }
+    is sb4, 47,
+      'sub foo{} applying to "state sub foo;" even inside state sub foo{}';
+  }->();
 }
 sub sc { 43 }
 {
@@ -342,6 +353,17 @@ is do foo(), 43, 'my sub falling out of scope (called via amper)';
   }
   is eval{mb3}, 47,
     'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
+  # Same test again, but inside an anonymous sub
+  sub {
+    my sub mb4;
+    {
+      my sub mb4 {
+        sub mb4 { 47 }
+      }
+    }
+    is mb4, 47,
+      'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
+  }->();
 }
 sub mc { 43 }
 {