Honour lexical prototypes

newCVREF is changed to return a PADCV op, not an RV2CV with a PADCV
kid, to keep the rv2cv_op_cv changes to a minimum.  (For some reason,
if newCVREF returns an RV2CV, we end up with two inside each other.)

I also added a test for recursion, since I nearly broke it.

diff --git a/op.c b/op.c
index 6e5bd91..21f271e 100644 (file)
--- a/op.c
+++ b/op.c
@@ -8128,6 +8128,7 @@ Perl_newCVREF(pTHX_ I32 flags, OP *o)
     if (o->op_type == OP_PADANY) {
        o->op_type = OP_PADCV;
        o->op_ppaddr = PL_ppaddr[OP_PADCV];
+       return o;
     }
     return newUNOP(OP_RV2CV, flags, scalar(o));
 }
@@ -9884,6 +9885,28 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
            cv = (CV*)SvRV(rv);
            gv = NULL;
        } break;
+       case OP_PADCV: {
+           PADNAME *name = PAD_COMPNAME(rvop->op_targ);
+           CV *compcv = PL_compcv;
+           SV *sv = PAD_SV(rvop->op_targ);
+           while (SvTYPE(sv) != SVt_PVCV) {
+               assert(PadnameOUTER(name));
+               assert(PARENT_PAD_INDEX(name));
+               compcv = CvOUTSIDE(PL_compcv);
+               sv = AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])
+                       [PARENT_PAD_INDEX(name)];
+               name = PadlistNAMESARRAY(CvPADLIST(compcv))
+                       [PARENT_PAD_INDEX(name)];
+           }
+           if (!PadnameIsOUR(name) && !PadnameIsSTATE(name)) {
+               MAGIC * mg = mg_find(sv, PERL_MAGIC_proto);
+               assert(mg);
+               assert(mg->mg_obj);
+               cv = (CV *)mg->mg_obj;
+           }
+           else cv = (CV *)sv;
+           gv = NULL;
+       } break;
        default: {
            return NULL;
        } break;
@@ -10470,6 +10493,19 @@ Perl_ck_subr(pTHX_ OP *o)
        Perl_call_checker ckfun;
        SV *ckobj;
        cv_get_call_checker(cv, &ckfun, &ckobj);
+       if (!namegv) { /* expletive! */
+           /* XXX The call checker API is public.  And it guarantees that
+                  a GV will be provided with the right name.  So we have
+                  to create a GV.  But it is still not correct, as its
+                  stringification will include the package.  What we
+                  really need is a new call checker API that accepts a
+                  GV or string (or GV or CV). */
+           HEK * const hek = CvNAME_HEK(cv);
+           assert(hek);
+           namegv = (GV *)sv_newmortal();
+           gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
+                       SVf_UTF8 * !!HEK_UTF8(hek));
+       }
        return ckfun(aTHX_ o, namegv, ckobj);
     }
 }

diff --git a/t/cmd/lexsub.t b/t/cmd/lexsub.t
index f982a0e..ebf1188 100644 (file)
--- a/t/cmd/lexsub.t
+++ b/t/cmd/lexsub.t
@@ -8,7 +8,7 @@ BEGIN {
     *bar::like = *like;
 }
 no warnings 'deprecated';
-plan 118;
+plan 121;
 
 # -------------------- our -------------------- #
 
@@ -280,6 +280,12 @@ sub make_anon_with_state_sub{
   is $w, "Subroutine redef redefined at pygpyf line 56.\n",
          "sub redefinition warnings from state subs";
 }
+{
+  state sub p (\@) {
+    is ref $_[0], 'ARRAY', 'state sub with proto';
+  }
+  p(my @a);
+}
 
 # -------------------- my -------------------- #
 
@@ -544,6 +550,19 @@ sub not_lexical10 {
   }
 }
 not_lexical11();
+{
+  my sub p (\@) {
+    is ref $_[0], 'ARRAY', 'my sub with proto';
+  }
+  p(my @a);
+}
+{
+  my sub x;
+  my $count;
+  sub x { x() if $count++ < 10 }
+  x();
+  is $count, 11, 'my recursive subs';
+}
 
 # -------------------- Interactions (and misc tests) -------------------- #