X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mro.c;h=ffb72abfc5fb5eca6fa8cbb20b2dd1500c0749c9;hb=95731d22654e3bfea37fa18440748a4fcd003948;hp=1e14bd179c2f0adc064711f4e51d22257a3a2def;hpb=1dcae2832b009ee3632057559967f11b1052d943;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mro.c b/mro.c index 1e14bd1..ffb72ab 100644 --- a/mro.c +++ b/mro.c @@ -21,19 +21,47 @@ These functions are related to the method resolution order of perl classes */ #include "EXTERN.h" +#define PERL_IN_MRO_C #include "perl.h" +struct mro_alg { + const char *name; + AV *(*resolve)(pTHX_ HV* stash, I32 level); +}; + +/* First one is the default */ +static struct mro_alg mros[] = { + {"dfs", S_mro_get_linear_isa_dfs}, + {"c3", S_mro_get_linear_isa_c3} +}; + +#define NUMBER_OF_MROS (sizeof(mros)/sizeof(struct mro_alg)) + +static const struct mro_alg * +S_get_mro_from_name(pTHX_ const char *const name) { + const struct mro_alg *algo = mros; + const struct mro_alg *const end = mros + NUMBER_OF_MROS; + while (algo < end) { + if(strEQ(name, algo->name)) + return algo; + ++algo; + } + return NULL; +} + struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash) { struct mro_meta* newmeta; - assert(stash); + PERL_ARGS_ASSERT_MRO_META_INIT; assert(HvAUX(stash)); assert(!(HvAUX(stash)->xhv_mro_meta)); Newxz(newmeta, 1, struct mro_meta); HvAUX(stash)->xhv_mro_meta = newmeta; newmeta->cache_gen = 1; + newmeta->pkg_gen = 1; + newmeta->mro_which = mros; return newmeta; } @@ -46,7 +74,7 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param) { struct mro_meta* newmeta; - assert(smeta); + PERL_ARGS_ASSERT_MRO_META_DUP; Newx(newmeta, 1, struct mro_meta); Copy(smeta, newmeta, 1, struct mro_meta); @@ -82,26 +110,26 @@ invalidated). =cut */ -AV* -Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) +static AV* +S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) { AV* retval; GV** gvp; GV* gv; AV* av; - const char* stashname; + const HEK* stashhek; struct mro_meta* meta; - assert(stash); + PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS; assert(HvAUX(stash)); - stashname = HvNAME_get(stash); - if (!stashname) + stashhek = HvNAME_HEK(stash); + if (!stashhek) Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", - stashname); + HEK_KEY(stashhek)); meta = HvMROMETA(stash); @@ -112,8 +140,8 @@ Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) /* not in cache, make a new one */ - retval = newAV(); - av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */ + retval = (AV*)sv_2mortal((SV *)newAV()); + av_push(retval, newSVhek(stashhek)); /* add ourselves at the top */ /* fetch our @ISA */ gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); @@ -145,7 +173,10 @@ Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) } else { /* otherwise, recurse into ourselves for the MRO - of this @ISA member, and append their MRO to ours */ + of this @ISA member, and append their MRO to ours. + The recursive call could throw an exception, which + has memory management implications here, hence the use of + the mortal. */ const AV *const subrv = mro_get_linear_isa_dfs(basestash, level + 1); @@ -154,14 +185,43 @@ Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) } while(subrv_items--) { SV *const subsv = *subrv_p++; - if(!hv_exists_ent(stored, subsv, 0)) { - hv_store_ent(stored, subsv, &PL_sv_undef, 0); - av_push(retval, newSVsv(subsv)); + /* LVALUE fetch will create a new undefined SV if necessary + */ + HE *const he = hv_fetch_ent(stored, subsv, 1, 0); + assert(he); + if(HeVAL(he) != &PL_sv_undef) { + /* It was newly created. Steal it for our new SV, and + replace it in the hash with the "real" thing. */ + SV *const val = HeVAL(he); + HEK *const key = HeKEY_hek(he); + + HeVAL(he) = &PL_sv_undef; + /* Save copying by making a shared hash key scalar. We + inline this here rather than calling Perl_newSVpvn_share + because we already have the scalar, and we already have + the hash key. */ + assert(SvTYPE(val) == SVt_NULL); + sv_upgrade(val, SVt_PV); + SvPV_set(val, HEK_KEY(share_hek_hek(key))); + SvCUR_set(val, HEK_LEN(key)); + SvREADONLY_on(val); + SvFAKE_on(val); + SvPOK_on(val); + if (HEK_UTF8(key)) + SvUTF8_on(val); + + av_push(retval, val); } } } } + /* now that we're past the exception dangers, grab our own reference to + the AV we're about to use for the result. The reference owned by the + mortals' stack will be released soon, so everything will balance. */ + SvREFCNT_inc_simple_void_NN(retval); + SvTEMP_off(retval); + /* we don't want anyone modifying the cache entry but us, and we do so by replacing it completely */ SvREADONLY_on(retval); @@ -187,28 +247,26 @@ invalidated). =cut */ -AV* -Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) +static AV* +S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) { AV* retval; GV** gvp; GV* gv; AV* isa; - const char* stashname; - STRLEN stashname_len; + const HEK* stashhek; struct mro_meta* meta; - assert(stash); + PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3; assert(HvAUX(stash)); - stashname = HvNAME_get(stash); - stashname_len = HvNAMELEN_get(stash); - if (!stashname) + stashhek = HvNAME_HEK(stash); + if (!stashhek) Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", - stashname); + HEK_KEY(stashhek)); meta = HvMROMETA(stash); @@ -242,19 +300,20 @@ Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) I32 items = AvFILLp(isa) + 1; SV** isa_ptr = AvARRAY(isa); while(items--) { - AV* isa_lin; SV* const isa_item = *isa_ptr++; HV* const isa_item_stash = gv_stashsv(isa_item, 0); if(!isa_item_stash) { /* if no stash, make a temporary fake MRO containing just itself */ - isa_lin = (AV*)sv_2mortal((SV*)newAV()); + AV* const isa_lin = newAV(); av_push(isa_lin, newSVsv(isa_item)); + av_push(seqs, (SV*)isa_lin); } else { - isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */ + /* recursion */ + AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); + av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin)); } - av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin)); } av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa)); @@ -277,12 +336,13 @@ Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) SV** seq_ptr = AvARRAY(seq) + 1; while(seq_items--) { SV* const seqitem = *seq_ptr++; - HE* const he = hv_fetch_ent(tails, seqitem, 0, 0); - if(!he) { - hv_store_ent(tails, seqitem, newSViv(1), 0); - } - else { + /* LVALUE fetch will create a new undefined SV if necessary + */ + HE* const he = hv_fetch_ent(tails, seqitem, 1, 0); + if(he) { SV* const val = HeVAL(he); + /* This will increment undef to 1, which is what we + want for a newly created entry. */ sv_inc(val); } } @@ -291,7 +351,7 @@ Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) /* Initialize retval to build the return value in */ retval = newAV(); - av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */ + av_push(retval, newSVhek(stashhek)); /* us first */ /* This loop won't terminate until we either finish building the MRO, or get an exception. */ @@ -370,14 +430,14 @@ Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) Safefree(heads); Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': " - "merging failed on parent '%"SVf"'", stashname, SVfARG(cand)); + "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand)); } } } else { /* @ISA was undefined or empty */ /* build a retval containing only ourselves */ retval = newAV(); - av_push(retval, newSVpvn(stashname, stashname_len)); + av_push(retval, newSVhek(stashhek)); } /* we don't want anyone modifying the cache entry but us, @@ -409,18 +469,15 @@ AV* Perl_mro_get_linear_isa(pTHX_ HV *stash) { struct mro_meta* meta; - assert(stash); - assert(HvAUX(stash)); + + PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA; + if(!SvOOK(stash)) + Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); meta = HvMROMETA(stash); - if(meta->mro_which == MRO_DFS) { - return mro_get_linear_isa_dfs(stash, 0); - } else if(meta->mro_which == MRO_C3) { - return mro_get_linear_isa_c3(stash, 0); - } else { + if (!meta->mro_which) Perl_croak(aTHX_ "panic: invalid MRO!"); - } - return NULL; /* NOT REACHED */ + return meta->mro_which->resolve(aTHX_ stash, 0); } /* @@ -442,17 +499,26 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) SV** svp; I32 items; bool is_universal; + struct mro_meta * meta; const char * const stashname = HvNAME_get(stash); const STRLEN stashname_len = HvNAMELEN_get(stash); + PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN; + + if(!stashname) + Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table"); + /* wipe out the cached linearizations for this stash */ - struct mro_meta * const meta = HvMROMETA(stash); + meta = HvMROMETA(stash); SvREFCNT_dec((SV*)meta->mro_linear_dfs); SvREFCNT_dec((SV*)meta->mro_linear_c3); meta->mro_linear_dfs = NULL; meta->mro_linear_c3 = NULL; + /* Inc the package generation, since our @ISA changed */ + meta->pkg_gen++; + /* Wipe the global method cache if this package is UNIVERSAL or one of its parents */ @@ -477,8 +543,9 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) if(isarev) { hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { - SV* const revkey = hv_iterkeysv(iter); - HV* revstash = gv_stashsv(revkey, 0); + I32 len; + const char* const revkey = hv_iterkey(iter, &len); + HV* revstash = gv_stashpvn(revkey, len, 0); struct mro_meta* revmeta; if(!revstash) continue; @@ -509,25 +576,29 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) SV* const sv = *svp++; HV* mroisarev; - HE *he = hv_fetch_ent(PL_isarev, sv, 0, 0); - if(!he) { - he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0); - } + HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0); + + /* That fetch should not fail. But if it had to create a new SV for + us, then will need to upgrade it to an HV (which sv_upgrade() can + now do for us. */ + mroisarev = (HV*)HeVAL(he); + SvUPGRADE((SV*)mroisarev, SVt_PVHV); + /* This hash only ever contains PL_sv_yes. Storing it over itself is almost as cheap as calling hv_exists, so on aggregate we expect to save time by not making two calls to the common HV code for the case where it doesn't exist. */ - hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0); + (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0); if(isarev) { hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { I32 revkeylen; char* const revkey = hv_iterkey(iter, &revkeylen); - hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0); + (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0); } } } @@ -572,6 +643,14 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); HV * const isarev = svp ? (HV*)*svp : NULL; + PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN; + + if(!stashname) + Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table"); + + /* Inc the package generation, since a local method changed */ + HvMROMETA(stash)->pkg_gen++; + /* If stash is UNIVERSAL, or one of UNIVERSAL's parents, invalidate all method caches globally */ if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) @@ -587,8 +666,9 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { - SV* const revkey = hv_iterkeysv(iter); - HV* const revstash = gv_stashsv(revkey, 0); + I32 len; + const char* const revkey = hv_iterkey(iter, &len); + HV* const revstash = gv_stashpvn(revkey, len, 0); struct mro_meta* mrometa; if(!revstash) continue; @@ -614,187 +694,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); @@ -804,9 +703,8 @@ XS(XS_mro_get_isarev); XS(XS_mro_is_universal); XS(XS_mro_invalidate_method_caches); XS(XS_mro_method_changed_in); -XS(XS_next_can); -XS(XS_next_method); -XS(XS_maybe_next_method); +XS(XS_mro_get_pkg_gen); +XS(XS_mro_nextcan); void Perl_boot_core_mro(pTHX) @@ -821,9 +719,8 @@ Perl_boot_core_mro(pTHX) newXSproto("mro::is_universal", XS_mro_is_universal, file, "$"); newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, ""); newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$"); - newXS("next::can", XS_next_can, file); - newXS("next::method", XS_next_method, file); - newXS("maybe::next::method", XS_maybe_next_method, file); + newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$"); + newXS("mro::_nextcan", XS_mro_nextcan, file); } XS(XS_mro_get_linear_isa) { @@ -833,23 +730,25 @@ XS(XS_mro_get_linear_isa) { HV* class_stash; SV* classname; - PERL_UNUSED_ARG(cv); - if(items < 1 || items > 2) - Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])"); + croak_xs_usage(cv, "classname [, type ]"); classname = ST(0); class_stash = gv_stashsv(classname, 0); - if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); - if(items > 1) { + if(!class_stash) { + /* No stash exists yet, give them just the classname */ + AV* isalin = newAV(); + av_push(isalin, newSVsv(classname)); + ST(0) = sv_2mortal(newRV_noinc((SV*)isalin)); + XSRETURN(1); + } + else if(items > 1) { const char* const which = SvPV_nolen(ST(1)); - if(strEQ(which, "dfs")) - RETVAL = mro_get_linear_isa_dfs(class_stash, 0); - else if(strEQ(which, "c3")) - RETVAL = mro_get_linear_isa_c3(class_stash, 0); - else - Perl_croak(aTHX_ "Invalid mro name: '%s'", which); + const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which); + if (!algo) + Perl_croak(aTHX_ "Invalid mro name: '%s'", which); + RETVAL = algo->resolve(aTHX_ class_stash, 0); } else { RETVAL = mro_get_linear_isa(class_stash); @@ -865,15 +764,13 @@ XS(XS_mro_set_mro) dVAR; dXSARGS; SV* classname; - char* whichstr; - mro_alg which; + const char* whichstr; + const struct mro_alg *which; HV* class_stash; struct mro_meta* meta; - PERL_UNUSED_ARG(cv); - if (items != 2) - Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)"); + croak_xs_usage(cv, "classname, type"); classname = ST(0); whichstr = SvPV_nolen(ST(1)); @@ -881,11 +778,8 @@ XS(XS_mro_set_mro) if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname)); meta = HvMROMETA(class_stash); - if(strEQ(whichstr, "dfs")) - which = MRO_DFS; - else if(strEQ(whichstr, "c3")) - which = MRO_C3; - else + which = S_get_mro_from_name(aTHX_ whichstr); + if (!which) Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr); if(meta->mro_which != which) { @@ -907,23 +801,16 @@ XS(XS_mro_get_mro) dXSARGS; SV* classname; HV* class_stash; - struct mro_meta* meta; - - PERL_UNUSED_ARG(cv); if (items != 1) - Perl_croak(aTHX_ "Usage: mro::get_mro(classname)"); + croak_xs_usage(cv, "classname"); classname = ST(0); class_stash = gv_stashsv(classname, 0); - if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); - meta = HvMROMETA(class_stash); - - if(meta->mro_which == MRO_DFS) - ST(0) = sv_2mortal(newSVpvn("dfs", 3)); - else - ST(0) = sv_2mortal(newSVpvn("c3", 2)); + ST(0) = sv_2mortal(newSVpv(class_stash + ? HvMROMETA(class_stash)->mro_which->name + : "dfs", 0)); XSRETURN(1); } @@ -932,35 +819,29 @@ XS(XS_mro_get_isarev) dVAR; dXSARGS; SV* classname; - HV* class_stash; - SV** svp; + HE* he; HV* isarev; - char* stashname; - STRLEN stashname_len; - - PERL_UNUSED_ARG(cv); + AV* ret_array; if (items != 1) - Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)"); + croak_xs_usage(cv, "classname"); classname = ST(0); - class_stash = gv_stashsv(classname, 0); - if(!class_stash) - Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); - SP -= items; - stashname = HvNAME_get(class_stash); - stashname_len = HvNAMELEN_get(class_stash); - svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); - isarev = svp ? (HV*)*svp : NULL; + + he = hv_fetch_ent(PL_isarev, classname, 0, 0); + isarev = he ? (HV*)HeVAL(he) : NULL; + + ret_array = newAV(); if(isarev) { HE* iter; hv_iterinit(isarev); while((iter = hv_iternext(isarev))) - XPUSHs(hv_iterkeysv(iter)); + av_push(ret_array, newSVsv(hv_iterkeysv(iter))); } + mXPUSHs(newRV_noinc((SV*)ret_array)); PUTBACK; return; @@ -971,28 +852,22 @@ XS(XS_mro_is_universal) dVAR; dXSARGS; SV* classname; - HV* class_stash; HV* isarev; - char* stashname; - STRLEN stashname_len; - SV** svp; - - PERL_UNUSED_ARG(cv); + char* classname_pv; + STRLEN classname_len; + HE* he; if (items != 1) - Perl_croak(aTHX_ "Usage: mro::is_universal(classname)"); + croak_xs_usage(cv, "classname"); classname = ST(0); - class_stash = gv_stashsv(classname, 0); - if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); - stashname = HvNAME_get(class_stash); - stashname_len = HvNAMELEN_get(class_stash); + classname_pv = SvPV(classname,classname_len); - svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); - isarev = svp ? (HV*)*svp : NULL; + he = hv_fetch_ent(PL_isarev, classname, 0, 0); + isarev = he ? (HV*)HeVAL(he) : NULL; - if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) + if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL")) || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) XSRETURN_YES; else @@ -1004,10 +879,8 @@ XS(XS_mro_invalidate_method_caches) dVAR; dXSARGS; - PERL_UNUSED_ARG(cv); - if (items != 0) - Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()"); + croak_xs_usage(cv, ""); PL_sub_generation++; @@ -1021,10 +894,8 @@ XS(XS_mro_method_changed_in) SV* classname; HV* class_stash; - PERL_UNUSED_ARG(cv); - if(items != 1) - Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)"); + croak_xs_usage(cv, "classname"); classname = ST(0); @@ -1036,55 +907,220 @@ XS(XS_mro_method_changed_in) XSRETURN_EMPTY; } -XS(XS_next_can) +XS(XS_mro_get_pkg_gen) { dVAR; dXSARGS; - SV* const self = ST(0); - SV* const methcv = __nextcan(aTHX_ self, 0); + SV* classname; + HV* class_stash; - PERL_UNUSED_ARG(cv); - PERL_UNUSED_VAR(items); + if(items != 1) + croak_xs_usage(cv, "classname"); + + classname = ST(0); - if(methcv == &PL_sv_undef) { - ST(0) = &PL_sv_undef; - } - else { - ST(0) = sv_2mortal(newRV_inc(methcv)); - } + class_stash = gv_stashsv(classname, 0); - XSRETURN(1); + SP -= items; + + mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0); + + PUTBACK; + return; } -XS(XS_next_method) +XS(XS_mro_nextcan) { - dMARK; - dAX; - SV* const self = ST(0); - SV* const methcv = __nextcan(aTHX_ self, 1); + dVAR; + dXSARGS; + SV* self = ST(0); + const I32 throw_nomethod = SvIVX(ST(1)); + register I32 cxix = cxstack_ix; + 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; + I32 i; PERL_UNUSED_ARG(cv); - PL_markstack_ptr++; - call_sv(methcv, GIMME_V); -} + SP -= items; -XS(XS_maybe_next_method) -{ - dMARK; - dAX; - SV* const self = ST(0); - SV* const methcv = __nextcan(aTHX_ self, 0); + if(sv_isobject(self)) + selfstash = SvSTASH(SvRV(self)); + else + selfstash = gv_stashsv(self, GV_ADD); - PERL_UNUSED_ARG(cv); + assert(selfstash); - if(methcv == &PL_sv_undef) { - ST(0) = &PL_sv_undef; - XSRETURN(1); + hvname = HvNAME_get(selfstash); + if (!hvname) + Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); + + /* 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 (also skips over pureperl next::method, etc) */ + for(i = 0; i < 2; i++) { + cxix = __dopoptosub_at(ccstack, cxix); + 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; + } + cxix--; + } + + /* 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; + } + mXPUSHs(newRV_inc(val)); + XSRETURN(1); + } + } + + /* beyond here is just for cache misses, so perf isn't as critical */ + + stashname_len = subname - fq_subname - 2; + stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP); + + linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */ + + linear_svp = AvARRAY(linear_av); + entries = AvFILLp(linear_av) + 1; + + /* 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; + } + + /* 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; + + 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); + (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0); + mXPUSHs(newRV_inc((SV*)cand_cv)); + XSRETURN(1); + } + } } - PL_markstack_ptr++; - call_sv(methcv, GIMME_V); + (void)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; } /*