diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | lib/mro.pm | 34 | ||||
| -rw-r--r-- | mro.c | 394 | ||||
| -rw-r--r-- | t/mro/next_goto.t | 35 |
4 files changed, 239 insertions, 225 deletions
@@ -3638,6 +3638,7 @@ t/mro/dbic_dfs.t mro tests t/mro/inconsistent_c3.t mro tests t/mro/method_caching.t mro tests t/mro/next_edgecases.t mro tests +t/mro/next_goto.t mro tests t/mro/next_inanon.t mro tests t/mro/next_ineval.t mro tests t/mro/next_method.t mro tests diff --git a/lib/mro.pm b/lib/mro.pm index 31da81bcb2..c4639382f1 100644 --- a/lib/mro.pm +++ b/lib/mro.pm @@ -9,14 +9,33 @@ package mro; use strict; use warnings; -# mro.pm versions < 1.00 reserved for possible CPAN mro dist -# (for partial back-compat to 5.[68].x) +# mro.pm versions < 1.00 reserved for MRO::Compat +# for partial back-compat to 5.[68].x our $VERSION = '1.00'; sub import { mro::set_mro(scalar(caller), $_[1]) if $_[1]; } +package # hide me from PAUSE + next; + +sub can { mro::_nextcan($_[0], 0) } + +sub method { + my $method = mro::_nextcan($_[0], 1); + goto &$method; +} + +package # hide me from PAUSE + maybe::next; + +sub method { + my $method = mro::_nextcan($_[0], 0); + goto &$method if defined $method; + return; +} + 1; __END__ @@ -27,6 +46,8 @@ mro - Method Resolution Order =head1 SYNOPSIS + use mro; # enables next::method and friends globally + use mro 'dfs'; # enable DFS MRO for this class (Perl default) use mro 'c3'; # enable C3 MRO for this class @@ -43,9 +64,12 @@ implementation for older Perls. It's possible to change the MRO of a given class either by using C<use mro> as shown in the synopsis, or by using the L</mro::set_mro> function -below. The functions do not require loading the C<mro> module, as they -are actually provided by the core perl interpreter. The C<use mro> syntax -is just syntactic sugar for setting the current package's MRO. +below. The functions in the mro namespace do not require loading the +C<mro> module, as they are actually provided by the core perl interpreter. + +The special methods C<next::method>, C<next::can>, and +C<maybe::next::method> are not available until this C<mro> module +has been loaded via C<use> or C<require>. =head1 The C3 MRO @@ -631,187 +631,6 @@ __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { return i; } -STATIC SV* -__nextcan(pTHX_ SV* self, I32 throw_nomethod) -{ - register I32 cxix; - register const PERL_CONTEXT *ccstack = cxstack; - const PERL_SI *top_si = PL_curstackinfo; - HV* selfstash; - SV *stashname; - const char *fq_subname; - const char *subname; - STRLEN stashname_len; - STRLEN subname_len; - SV* sv; - GV** gvp; - AV* linear_av; - SV** linear_svp; - const char *hvname; - I32 items; - struct mro_meta* selfmeta; - HV* nmcache; - - if(sv_isobject(self)) - selfstash = SvSTASH(SvRV(self)); - else - selfstash = gv_stashsv(self, 0); - - assert(selfstash); - - hvname = HvNAME_get(selfstash); - if (!hvname) - Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); - - cxix = __dopoptosub_at(cxstack, cxstack_ix); - - /* This block finds the contextually-enclosing fully-qualified subname, - much like looking at (caller($i))[3] until you find a real sub that - isn't ANON, etc */ - for (;;) { - GV* cvgv; - STRLEN fq_subname_len; - - /* we may be in a higher stacklevel, so dig down deeper */ - while (cxix < 0) { - if(top_si->si_type == PERLSI_MAIN) - Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context"); - top_si = top_si->si_prev; - ccstack = top_si->si_cxstack; - cxix = __dopoptosub_at(ccstack, top_si->si_cxix); - } - - if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB - || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) { - cxix = __dopoptosub_at(ccstack, cxix - 1); - continue; - } - - { - const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1); - if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) { - if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) { - cxix = dbcxix; - continue; - } - } - } - - cvgv = CvGV(ccstack[cxix].blk_sub.cv); - - if(!isGV(cvgv)) { - cxix = __dopoptosub_at(ccstack, cxix - 1); - continue; - } - - /* we found a real sub here */ - sv = sv_2mortal(newSV(0)); - - gv_efullname3(sv, cvgv, NULL); - - fq_subname = SvPVX(sv); - fq_subname_len = SvCUR(sv); - - subname = strrchr(fq_subname, ':'); - if(!subname) - Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method"); - - subname++; - subname_len = fq_subname_len - (subname - fq_subname); - if(subname_len == 8 && strEQ(subname, "__ANON__")) { - cxix = __dopoptosub_at(ccstack, cxix - 1); - continue; - } - break; - } - - /* If we made it to here, we found our context */ - - /* Initialize the next::method cache for this stash - if necessary */ - selfmeta = HvMROMETA(selfstash); - if(!(nmcache = selfmeta->mro_nextmethod)) { - nmcache = selfmeta->mro_nextmethod = newHV(); - } - else { /* Use the cached coderef if it exists */ - HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0); - if (cache_entry) { - SV* const val = HeVAL(cache_entry); - if(val == &PL_sv_undef) { - if(throw_nomethod) - Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); - } - return val; - } - } - - /* beyond here is just for cache misses, so perf isn't as critical */ - - stashname_len = subname - fq_subname - 2; - stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len)); - - linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */ - - linear_svp = AvARRAY(linear_av); - items = AvFILLp(linear_av) + 1; - - /* Walk down our MRO, skipping everything up - to the contextually enclosing class */ - while (items--) { - SV * const linear_sv = *linear_svp++; - assert(linear_sv); - if(sv_eq(linear_sv, stashname)) - break; - } - - /* Now search the remainder of the MRO for the - same method name as the contextually enclosing - method */ - if(items > 0) { - while (items--) { - SV * const linear_sv = *linear_svp++; - HV* curstash; - GV* candidate; - CV* cand_cv; - - assert(linear_sv); - curstash = gv_stashsv(linear_sv, FALSE); - - if (!curstash) { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", - (void*)linear_sv, hvname); - continue; - } - - assert(curstash); - - gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0); - if (!gvp) continue; - - candidate = *gvp; - assert(candidate); - - if (SvTYPE(candidate) != SVt_PVGV) - gv_init(candidate, curstash, subname, subname_len, TRUE); - - /* Notably, we only look for real entries, not method cache - entries, because in C3 the method cache of a parent is not - valid for the child */ - if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { - SvREFCNT_inc_simple_void_NN((SV*)cand_cv); - hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0); - return (SV*)cand_cv; - } - } - } - - hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0); - if(throw_nomethod) - Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); - return &PL_sv_undef; -} - #include "XSUB.h" XS(XS_mro_get_linear_isa); @@ -822,9 +641,7 @@ XS(XS_mro_is_universal); XS(XS_mro_invalidate_method_caches); XS(XS_mro_method_changed_in); XS(XS_mro_get_pkg_gen); -XS(XS_next_can); -XS(XS_next_method); -XS(XS_maybe_next_method); +XS(XS_mro_nextcan); void Perl_boot_core_mro(pTHX) @@ -840,9 +657,7 @@ Perl_boot_core_mro(pTHX) newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, ""); newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$"); newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$"); - newXS("next::can", XS_next_can, file); - newXS("next::method", XS_next_method, file); - newXS("maybe::next::method", XS_maybe_next_method, file); + newXS("mro::_nextcan", XS_mro_nextcan, file); } XS(XS_mro_get_linear_isa) { @@ -1081,55 +896,194 @@ XS(XS_mro_get_pkg_gen) return; } -XS(XS_next_can) +XS(XS_mro_nextcan) { dVAR; dXSARGS; - SV* const self = ST(0); - SV* const methcv = __nextcan(aTHX_ self, 0); + SV* self = ST(0); + const I32 throw_nomethod = SvIVX(ST(1)); + register I32 cxix; + register const PERL_CONTEXT *ccstack = cxstack; + const PERL_SI *top_si = PL_curstackinfo; + HV* selfstash; + SV *stashname; + const char *fq_subname; + const char *subname; + STRLEN stashname_len; + STRLEN subname_len; + SV* sv; + GV** gvp; + AV* linear_av; + SV** linear_svp; + const char *hvname; + I32 entries; + struct mro_meta* selfmeta; + HV* nmcache; - PERL_UNUSED_ARG(cv); - PERL_UNUSED_VAR(items); + SP -= items; + + if(sv_isobject(self)) + selfstash = SvSTASH(SvRV(self)); + else + selfstash = gv_stashsv(self, 0); + + assert(selfstash); + + hvname = HvNAME_get(selfstash); + if (!hvname) + Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); + + cxix = __dopoptosub_at(cxstack, cxstack_ix); + cxix = __dopoptosub_at(ccstack, cxix - 1); /* skip next::method, etc */ + + /* This block finds the contextually-enclosing fully-qualified subname, + much like looking at (caller($i))[3] until you find a real sub that + isn't ANON, etc */ + for (;;) { + GV* cvgv; + STRLEN fq_subname_len; + + /* we may be in a higher stacklevel, so dig down deeper */ + while (cxix < 0) { + if(top_si->si_type == PERLSI_MAIN) + Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context"); + top_si = top_si->si_prev; + ccstack = top_si->si_cxstack; + cxix = __dopoptosub_at(ccstack, top_si->si_cxix); + } + + if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB + || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) { + cxix = __dopoptosub_at(ccstack, cxix - 1); + continue; + } - if(methcv == &PL_sv_undef) { - ST(0) = &PL_sv_undef; + { + const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1); + if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) { + if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) { + cxix = dbcxix; + continue; + } + } + } + + cvgv = CvGV(ccstack[cxix].blk_sub.cv); + + if(!isGV(cvgv)) { + cxix = __dopoptosub_at(ccstack, cxix - 1); + continue; + } + + /* we found a real sub here */ + sv = sv_2mortal(newSV(0)); + + gv_efullname3(sv, cvgv, NULL); + + fq_subname = SvPVX(sv); + fq_subname_len = SvCUR(sv); + + subname = strrchr(fq_subname, ':'); + if(!subname) + Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method"); + + subname++; + subname_len = fq_subname_len - (subname - fq_subname); + if(subname_len == 8 && strEQ(subname, "__ANON__")) { + cxix = __dopoptosub_at(ccstack, cxix - 1); + continue; + } + break; } - else { - ST(0) = sv_2mortal(newRV_inc(methcv)); + + /* If we made it to here, we found our context */ + + /* Initialize the next::method cache for this stash + if necessary */ + selfmeta = HvMROMETA(selfstash); + if(!(nmcache = selfmeta->mro_nextmethod)) { + nmcache = selfmeta->mro_nextmethod = newHV(); + } + else { /* Use the cached coderef if it exists */ + HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0); + if (cache_entry) { + SV* const val = HeVAL(cache_entry); + if(val == &PL_sv_undef) { + if(throw_nomethod) + Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); + XSRETURN_EMPTY; + } + XPUSHs(sv_2mortal(newRV_inc(val))); + XSRETURN(1); + } } - XSRETURN(1); -} + /* beyond here is just for cache misses, so perf isn't as critical */ -XS(XS_next_method) -{ - dMARK; - dAX; - SV* const self = ST(0); - SV* const methcv = __nextcan(aTHX_ self, 1); + stashname_len = subname - fq_subname - 2; + stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len)); - PERL_UNUSED_ARG(cv); + linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */ - PL_markstack_ptr++; - call_sv(methcv, GIMME_V); -} + linear_svp = AvARRAY(linear_av); + entries = AvFILLp(linear_av) + 1; -XS(XS_maybe_next_method) -{ - dMARK; - dAX; - SV* const self = ST(0); - SV* const methcv = __nextcan(aTHX_ self, 0); + /* Walk down our MRO, skipping everything up + to the contextually enclosing class */ + while (entries--) { + SV * const linear_sv = *linear_svp++; + assert(linear_sv); + if(sv_eq(linear_sv, stashname)) + break; + } - PERL_UNUSED_ARG(cv); + /* Now search the remainder of the MRO for the + same method name as the contextually enclosing + method */ + if(entries > 0) { + while (entries--) { + SV * const linear_sv = *linear_svp++; + HV* curstash; + GV* candidate; + CV* cand_cv; - if(methcv == &PL_sv_undef) { - ST(0) = &PL_sv_undef; - XSRETURN(1); + assert(linear_sv); + curstash = gv_stashsv(linear_sv, FALSE); + + if (!curstash) { + if (ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", + (void*)linear_sv, hvname); + continue; + } + + assert(curstash); + + gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0); + if (!gvp) continue; + + candidate = *gvp; + assert(candidate); + + if (SvTYPE(candidate) != SVt_PVGV) + gv_init(candidate, curstash, subname, subname_len, TRUE); + + /* Notably, we only look for real entries, not method cache + entries, because in C3 the method cache of a parent is not + valid for the child */ + if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { + SvREFCNT_inc_simple_void_NN((SV*)cand_cv); + hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0); + XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv))); + XSRETURN(1); + } + } } - PL_markstack_ptr++; - call_sv(methcv, GIMME_V); + hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0); + if(throw_nomethod) + Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); + XSRETURN_EMPTY; } /* diff --git a/t/mro/next_goto.t b/t/mro/next_goto.t new file mode 100644 index 0000000000..b7a33ec0e5 --- /dev/null +++ b/t/mro/next_goto.t @@ -0,0 +1,35 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +require q(./test.pl); plan(tests => 4); + +use mro; + +{ + package Proxy; + our @ISA = qw//; + sub next_proxy { goto &next::method } + sub maybe_proxy { goto &maybe::next::method } + sub can_proxy { goto &next::can } + + package TBase; + our @ISA = qw//; + sub foo { 42 } + sub bar { 24 } + # baz doesn't exist intentionally + sub quux { 242 } + + package TTop; + our @ISA = qw/TBase/; + sub foo { shift->Proxy::next_proxy() } + sub bar { shift->Proxy::maybe_proxy() } + sub baz { shift->Proxy::maybe_proxy() } + sub quux { shift->Proxy::can_proxy()->() } +} + +is(TTop->foo, 42, 'proxy next::method via goto'); +is(TTop->bar, 24, 'proxy maybe::next::method via goto'); +ok(!TTop->baz, 'proxy maybe::next::method via goto with no method'); +is(TTop->quux, 242, 'proxy next::can via goto'); |