In perl.git, the branch sprout/lexsub has been updated <http://perl5.git.perl.org/perl.git/commitdiff/d730f874fa06b4a8733738a11e7ed204b62da79d?hp=71eee7327ed8968dd2776b7471e1e24646637e8e>
- Log ----------------------------------------------------------------- commit d730f874fa06b4a8733738a11e7ed204b62da79d Author: Father Chrysostomos <spr...@cpan.org> Date: Sat Sep 8 19:28:00 2012 -0700 Honour lexical prototypes ----------------------------------------------------------------------- Summary of changes: op.c | 36 ++++++++++++++++++++++++++++++++++++ t/cmd/lexsub.t | 14 +++++++++++++- 2 files changed, 49 insertions(+), 1 deletions(-) diff --git a/op.c b/op.c index 605256b..96216d0 100644 --- a/op.c +++ b/op.c @@ -8098,6 +8098,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)); } @@ -9854,6 +9855,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))) + [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; @@ -10440,6 +10463,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..d9ed6fc 100644 --- a/t/cmd/lexsub.t +++ b/t/cmd/lexsub.t @@ -8,7 +8,7 @@ BEGIN { *bar::like = *like; } no warnings 'deprecated'; -plan 118; +plan 120; # -------------------- 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,12 @@ sub not_lexical10 { } } not_lexical11(); +{ + my sub p (\@) { + is ref $_[0], 'ARRAY', 'my sub with proto'; + } + p(my @a); +} # -------------------- Interactions (and misc tests) -------------------- # -- Perl5 Master Repository