X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mro.c;h=1e14bd179c2f0adc064711f4e51d22257a3a2def;hb=b79e0b55ef5115cd52e297916c79b760512d400a;hp=81626adf1db978aec5c0497da8540b3ad5b47d5f;hpb=25270bc0b7409c7dbdeef1a6ec0b548e2d3e51a1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mro.c b/mro.c index 81626ad..1e14bd1 100644 --- a/mro.c +++ b/mro.c @@ -33,17 +33,7 @@ Perl_mro_meta_init(pTHX_ HV* stash) assert(!(HvAUX(stash)->xhv_mro_meta)); Newxz(newmeta, 1, struct mro_meta); HvAUX(stash)->xhv_mro_meta = newmeta; - newmeta->sub_generation = 1; - - /* Manually flag UNIVERSAL as being universal. - This happens early in perl booting (when universal.c - does the newXS calls for UNIVERSAL::*), and infects - other packages as they are added to UNIVERSAL's MRO - */ - if(HvNAMELEN_get(stash) == 9 - && strEQ(HEK_KEY(HvAUX(stash)->xhv_name), "UNIVERSAL")) { - HvMROMETA(stash)->is_universal = 1; - } + newmeta->cache_gen = 1; return newmeta; } @@ -67,9 +57,6 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param) if (newmeta->mro_linear_c3) newmeta->mro_linear_c3 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param)); - if (newmeta->mro_isarev) - newmeta->mro_isarev - = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_isarev, param)); if (newmeta->mro_nextmethod) newmeta->mro_nextmethod = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param)); @@ -110,8 +97,7 @@ Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) stashname = HvNAME_get(stash); if (!stashname) - Perl_croak(aTHX_ - "Can't linearize anonymous symbol table"); + Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", @@ -140,7 +126,7 @@ Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) exists check and avoid adding duplicate classnames to the MRO as we go. */ - HV* stored = (HV*)sv_2mortal((SV*)newHV()); + HV* const stored = (HV*)sv_2mortal((SV*)newHV()); SV **svp = AvARRAY(av); I32 items = AvFILLp(av) + 1; @@ -218,8 +204,7 @@ Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) stashname = HvNAME_get(stash); stashname_len = HvNAMELEN_get(stash); if (!stashname) - Perl_croak(aTHX_ - "Can't linearize anonymous symbol table"); + Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", @@ -234,9 +219,6 @@ Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) /* not in cache, make a new one */ - retval = newAV(); - av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */ - gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL; @@ -245,65 +227,96 @@ Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm (later versions go about it differently than this code for speed reasons) */ + if(isa && AvFILLp(isa) >= 0) { SV** seqs_ptr; I32 seqs_items; - HV* tails = (HV*)sv_2mortal((SV*)newHV()); - AV* seqs = (AV*)sv_2mortal((SV*)newAV()); + HV* const tails = (HV*)sv_2mortal((SV*)newHV()); + AV* const seqs = (AV*)sv_2mortal((SV*)newAV()); + I32* heads; + + /* This builds @seqs, which is an array of arrays. + The members of @seqs are the MROs of + the members of @ISA, followed by @ISA itself. + */ I32 items = AvFILLp(isa) + 1; SV** isa_ptr = AvARRAY(isa); while(items--) { AV* isa_lin; - SV* isa_item = *isa_ptr++; - HV* isa_item_stash = gv_stashsv(isa_item, 0); + SV* const isa_item = *isa_ptr++; + HV* const isa_item_stash = gv_stashsv(isa_item, 0); if(!isa_item_stash) { - isa_lin = newAV(); + /* if no stash, make a temporary fake MRO + containing just itself */ + isa_lin = (AV*)sv_2mortal((SV*)newAV()); av_push(isa_lin, newSVsv(isa_item)); } else { isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */ } - av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin))); + av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin)); } - av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa))); - + av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa)); + + /* This builds "heads", which as an array of integer array + indices, one per seq, which point at the virtual "head" + of the seq (initially zero) */ + Newxz(heads, AvFILLp(seqs)+1, I32); + + /* This builds %tails, which has one key for every class + mentioned in the tail of any sequence in @seqs (tail meaning + everything after the first class, the "head"). The value + is how many times this key appears in the tails of @seqs. + */ seqs_ptr = AvARRAY(seqs); seqs_items = AvFILLp(seqs) + 1; while(seqs_items--) { - AV* seq = (AV*)*seqs_ptr++; + AV* const seq = (AV*)*seqs_ptr++; I32 seq_items = AvFILLp(seq); if(seq_items > 0) { SV** seq_ptr = AvARRAY(seq) + 1; while(seq_items--) { - SV* seqitem = *seq_ptr++; - HE* he = hv_fetch_ent(tails, seqitem, 0, 0); + 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 { - SV* val = HeVAL(he); + SV* const val = HeVAL(he); sv_inc(val); } } } } + /* Initialize retval to build the return value in */ + retval = newAV(); + av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */ + + /* This loop won't terminate until we either finish building + the MRO, or get an exception. */ while(1) { - SV* seqhead = NULL; SV* cand = NULL; SV* winner = NULL; - SV* val; - HE* tail_entry; - AV* seq; - SV** avptr = AvARRAY(seqs); - items = AvFILLp(seqs)+1; - while(items--) { + int s; + + /* "foreach $seq (@seqs)" */ + SV** const avptr = AvARRAY(seqs); + for(s = 0; s <= AvFILLp(seqs); s++) { SV** svp; - seq = (AV*)*avptr++; - if(AvFILLp(seq) < 0) continue; - svp = av_fetch(seq, 0, 0); - seqhead = *svp; + AV * const seq = (AV*)(avptr[s]); + SV* seqhead; + if(!seq) continue; /* skip empty seqs */ + svp = av_fetch(seq, heads[s], 0); + seqhead = *svp; /* seqhead = head of this seq */ if(!winner) { + HE* tail_entry; + SV* val; + /* if we haven't found a winner for this round yet, + and this seqhead is not in tails (or the count + for it in tails has dropped to zero), then this + seqhead is our new winner, and is added to the + final MRO immediately */ cand = seqhead; if((tail_entry = hv_fetch_ent(tails, cand, 0, 0)) && (val = HeVAL(tail_entry)) @@ -311,32 +324,61 @@ Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) continue; winner = newSVsv(cand); av_push(retval, winner); + /* note however that even when we find a winner, + we continue looping over @seqs to do housekeeping */ } if(!sv_cmp(seqhead, winner)) { - - /* this is basically shift(@seq) in void context */ - SvREFCNT_dec(*AvARRAY(seq)); - *AvARRAY(seq) = &PL_sv_undef; - AvARRAY(seq) = AvARRAY(seq) + 1; - AvMAX(seq)--; - AvFILLp(seq)--; - - if(AvFILLp(seq) < 0) continue; - svp = av_fetch(seq, 0, 0); - seqhead = *svp; - tail_entry = hv_fetch_ent(tails, seqhead, 0, 0); - val = HeVAL(tail_entry); - sv_dec(val); + /* Once we have a winner (including the iteration + where we first found him), inc the head ptr + for any seq which had the winner as a head, + NULL out any seq which is now empty, + and adjust tails for consistency */ + + const int new_head = ++heads[s]; + if(new_head > AvFILLp(seq)) { + SvREFCNT_dec(avptr[s]); + avptr[s] = NULL; + } + else { + HE* tail_entry; + SV* val; + /* Because we know this new seqhead used to be + a tail, we can assume it is in tails and has + a positive value, which we need to dec */ + svp = av_fetch(seq, new_head, 0); + seqhead = *svp; + tail_entry = hv_fetch_ent(tails, seqhead, 0, 0); + val = HeVAL(tail_entry); + sv_dec(val); + } } } - if(!cand) break; + + /* if we found no candidates, we are done building the MRO. + !cand means no seqs have any entries left to check */ + if(!cand) { + Safefree(heads); + break; + } + + /* If we had candidates, but nobody won, then the @ISA + hierarchy is not C3-incompatible */ if(!winner) { + /* we have to do some cleanup before we croak */ + SvREFCNT_dec(retval); + Safefree(heads); + Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': " "merging failed on parent '%"SVf"'", stashname, SVfARG(cand)); } } } + else { /* @ISA was undefined or empty */ + /* build a retval containing only ourselves */ + retval = newAV(); + av_push(retval, newSVpvn(stashname, stashname_len)); + } /* we don't want anyone modifying the cache entry but us, and we do so by replacing it completely */ @@ -378,6 +420,7 @@ Perl_mro_get_linear_isa(pTHX_ HV *stash) } else { Perl_croak(aTHX_ "panic: invalid MRO!"); } + return NULL; /* NOT REACHED */ } /* @@ -398,13 +441,13 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) HE* iter; SV** svp; I32 items; - struct mro_meta* meta; - char* stashname; + bool is_universal; - stashname = HvNAME_get(stash); + const char * const stashname = HvNAME_get(stash); + const STRLEN stashname_len = HvNAMELEN_get(stash); /* wipe out the cached linearizations for this stash */ - meta = HvMROMETA(stash); + struct mro_meta * const meta = HvMROMETA(stash); SvREFCNT_dec((SV*)meta->mro_linear_dfs); SvREFCNT_dec((SV*)meta->mro_linear_c3); meta->mro_linear_dfs = NULL; @@ -412,30 +455,40 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) /* Wipe the global method cache if this package is UNIVERSAL or one of its parents */ - if(meta->is_universal) - PL_sub_generation++; - /* Wipe the local method cache otherwise */ - else - meta->sub_generation++; + svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); + isarev = svp ? (HV*)*svp : NULL; + + if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) + || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { + PL_sub_generation++; + is_universal = TRUE; + } + else { /* Wipe the local method cache otherwise */ + meta->cache_gen++; + is_universal = FALSE; + } /* wipe next::method cache too */ if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod); - + /* Iterate the isarev (classes that are our children), wiping out their linearization and method caches */ - if((isarev = meta->mro_isarev)) { + if(isarev) { hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { - SV* revkey = hv_iterkeysv(iter); + SV* const revkey = hv_iterkeysv(iter); HV* revstash = gv_stashsv(revkey, 0); - struct mro_meta* revmeta = HvMROMETA(revstash); + struct mro_meta* revmeta; + + if(!revstash) continue; + revmeta = HvMROMETA(revstash); SvREFCNT_dec((SV*)revmeta->mro_linear_dfs); SvREFCNT_dec((SV*)revmeta->mro_linear_c3); revmeta->mro_linear_dfs = NULL; revmeta->mro_linear_c3 = NULL; - if(!meta->is_universal) - revmeta->sub_generation++; + if(!is_universal) + revmeta->cache_gen++; if(revmeta->mro_nextmethod) hv_clear(revmeta->mro_nextmethod); } @@ -454,44 +507,27 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) while (items--) { SV* const sv = *svp++; - struct mro_meta* mrometa; HV* mroisarev; - HV* mrostash = gv_stashsv(sv, 0); - if(!mrostash) { - mrostash = gv_stashsv(sv, GV_ADD); - /* - We created the package on the fly, so - that we could store isarev information. - This flag lets gv_fetchmeth know about it, - so that it can still generate the very useful - "Can't locate package Foo for @Bar::ISA" warning. - */ - HvMROMETA(mrostash)->fake = 1; + HE *he = hv_fetch_ent(PL_isarev, sv, 0, 0); + if(!he) { + he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0); } - - mrometa = HvMROMETA(mrostash); - mroisarev = mrometa->mro_isarev; - - /* is_universal is viral */ - if(meta->is_universal) - mrometa->is_universal = 1; - - if(!mroisarev) - mroisarev = mrometa->mro_isarev = newHV(); + mroisarev = (HV*)HeVAL(he); /* 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, strlen(stashname), &PL_sv_yes, 0); + hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0); if(isarev) { hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { - SV* revkey = hv_iterkeysv(iter); - hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0); + I32 revkeylen; + char* const revkey = hv_iterkey(iter, &revkeylen); + hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0); } } } @@ -500,51 +536,64 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) /* =for apidoc mro_method_changed_in -Like C, but invalidates method -caching on any child classes of the given stash, so -that they might notice the changes in this one. +Invalidates method caching on any child classes +of the given stash, so that they might notice +the changes in this one. Ideally, all instances of C in -the perl source should be replaced by calls to this. -Some already are, but some are more difficult to -replace. +perl source outside of C should be +replaced by calls to this. + +Perl automatically handles most of the common +ways a method might be redefined. However, there +are a few ways you could change a method in a stash +without the cache code noticing, in which case you +need to call this method afterwards: -Perl has always had problems with method caches -getting out of sync when one directly manipulates -stashes via things like C<%{Foo::} = %{Bar::}> or -C<${Foo::}{bar} = ...> or the equivalent. If -you do this in core or XS code, call this afterwards -on the destination stash to get things back in sync. +1) Directly manipulating the stash HV entries from +XS code. -If you're doing such a thing from pure perl, use -C, which -just calls this. +2) Assigning a reference to a readonly scalar +constant into a stash entry in order to create +a constant subroutine (like constant.pm +does). + +This same method is available from pure perl +via, C. =cut */ void Perl_mro_method_changed_in(pTHX_ HV *stash) { - struct mro_meta* meta = HvMROMETA(stash); - HV* isarev; - HE* iter; + const char * const stashname = HvNAME_get(stash); + const STRLEN stashname_len = HvNAMELEN_get(stash); + + SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); + HV * const isarev = svp ? (HV*)*svp : NULL; /* If stash is UNIVERSAL, or one of UNIVERSAL's parents, invalidate all method caches globally */ - if(meta->is_universal) { + if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) + || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { PL_sub_generation++; return; } /* else, invalidate the method caches of all child classes, but not itself */ - if((isarev = meta->mro_isarev)) { + if(isarev) { + HE* iter; + hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { - SV* revkey = hv_iterkeysv(iter); - HV* revstash = gv_stashsv(revkey, 0); - struct mro_meta* mrometa = HvMROMETA(revstash); - mrometa->sub_generation++; + SV* const revkey = hv_iterkeysv(iter); + HV* const revstash = gv_stashsv(revkey, 0); + struct mro_meta* mrometa; + + if(!revstash) continue; + mrometa = HvMROMETA(revstash); + mrometa->cache_gen++; if(mrometa->mro_nextmethod) hv_clear(mrometa->mro_nextmethod); } @@ -572,26 +621,19 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) register const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; HV* selfstash; - GV* cvgv; SV *stashname; const char *fq_subname; const char *subname; - STRLEN fq_subname_len; STRLEN stashname_len; STRLEN subname_len; SV* sv; GV** gvp; AV* linear_av; SV** linear_svp; - SV* linear_sv; - HV* curstash; - GV* candidate = NULL; - CV* cand_cv = NULL; const char *hvname; I32 items; struct mro_meta* selfmeta; HV* nmcache; - HE* cache_entry; if(sv_isobject(self)) selfstash = SvSTASH(SvRV(self)); @@ -610,6 +652,9 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) 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) @@ -671,15 +716,16 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) if(!(nmcache = selfmeta->mro_nextmethod)) { nmcache = selfmeta->mro_nextmethod = newHV(); } - - /* Use the cached coderef if it exists */ - else if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) { - SV* 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; + 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 */ @@ -695,7 +741,7 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) /* Walk down our MRO, skipping everything up to the contextually enclosing class */ while (items--) { - linear_sv = *linear_svp++; + SV * const linear_sv = *linear_svp++; assert(linear_sv); if(sv_eq(linear_sv, stashname)) break; @@ -706,11 +752,15 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) method */ if(items > 0) { while (items--) { - linear_sv = *linear_svp++; + SV * const linear_sv = *linear_svp++; + HV* curstash; + GV* candidate; + CV* cand_cv; + assert(linear_sv); curstash = gv_stashsv(linear_sv, FALSE); - if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) { + if (!curstash) { if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", (void*)linear_sv, hvname); @@ -752,9 +802,7 @@ XS(XS_mro_set_mro); XS(XS_mro_get_mro); XS(XS_mro_get_isarev); XS(XS_mro_is_universal); -XS(XS_mro_get_global_sub_generation); -XS(XS_mro_invalidate_all_method_caches); -XS(XS_mro_get_sub_generation); +XS(XS_mro_invalidate_method_caches); XS(XS_mro_method_changed_in); XS(XS_next_can); XS(XS_next_method); @@ -771,9 +819,7 @@ Perl_boot_core_mro(pTHX) newXSproto("mro::get_mro", XS_mro_get_mro, file, "$"); newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$"); newXSproto("mro::is_universal", XS_mro_is_universal, file, "$"); - newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_generation, file, ""); - newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_all_method_caches, file, ""); - newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, 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); @@ -797,7 +843,7 @@ XS(XS_mro_get_linear_isa) { if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); if(items > 1) { - char* which = SvPV_nolen(ST(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")) @@ -846,7 +892,7 @@ XS(XS_mro_set_mro) meta->mro_which = which; /* Only affects local method cache, not even child classes */ - meta->sub_generation++; + meta->cache_gen++; if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod); } @@ -887,7 +933,10 @@ XS(XS_mro_get_isarev) dXSARGS; SV* classname; HV* class_stash; + SV** svp; HV* isarev; + char* stashname; + STRLEN stashname_len; PERL_UNUSED_ARG(cv); @@ -897,11 +946,16 @@ XS(XS_mro_get_isarev) classname = ST(0); class_stash = gv_stashsv(classname, 0); - if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); + if(!class_stash) + Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); SP -= items; - - if((isarev = HvMROMETA(class_stash)->mro_isarev)) { + + 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; + if(isarev) { HE* iter; hv_iterinit(isarev); while((iter = hv_iternext(isarev))) @@ -918,37 +972,34 @@ XS(XS_mro_is_universal) dXSARGS; SV* classname; HV* class_stash; + HV* isarev; + char* stashname; + STRLEN stashname_len; + SV** svp; PERL_UNUSED_ARG(cv); if (items != 1) - Perl_croak(aTHX_ "Usage: mro::get_mro(classname)"); + Perl_croak(aTHX_ "Usage: mro::is_universal(classname)"); classname = ST(0); class_stash = gv_stashsv(classname, 0); if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); - if (HvMROMETA(class_stash)->is_universal) + 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; + + if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) + || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) XSRETURN_YES; else XSRETURN_NO; } -XS(XS_mro_get_global_sub_generation) -{ - dVAR; - dXSARGS; - - PERL_UNUSED_ARG(cv); - - if (items != 0) - Perl_croak(aTHX_ "Usage: mro::get_global_sub_generation()"); - - ST(0) = sv_2mortal(newSViv(PL_sub_generation)); - XSRETURN(1); -} - -XS(XS_mro_invalidate_all_method_caches) +XS(XS_mro_invalidate_method_caches) { dVAR; dXSARGS; @@ -963,26 +1014,6 @@ XS(XS_mro_invalidate_all_method_caches) XSRETURN_EMPTY; } -XS(XS_mro_get_sub_generation) -{ - dVAR; - dXSARGS; - SV* classname; - HV* class_stash; - - PERL_UNUSED_ARG(cv); - - if(items != 1) - Perl_croak(aTHX_ "Usage: mro::get_sub_generation(classname)"); - - classname = ST(0); - class_stash = gv_stashsv(classname, 0); - if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); - - ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation)); - XSRETURN(1); -} - XS(XS_mro_method_changed_in) { dVAR; @@ -1009,8 +1040,8 @@ XS(XS_next_can) { dVAR; dXSARGS; - SV* self = ST(0); - SV* methcv = __nextcan(aTHX_ self, 0); + SV* const self = ST(0); + SV* const methcv = __nextcan(aTHX_ self, 0); PERL_UNUSED_ARG(cv); PERL_UNUSED_VAR(items); @@ -1029,8 +1060,8 @@ XS(XS_next_method) { dMARK; dAX; - SV* self = ST(0); - SV* methcv = __nextcan(aTHX_ self, 1); + SV* const self = ST(0); + SV* const methcv = __nextcan(aTHX_ self, 1); PERL_UNUSED_ARG(cv); @@ -1042,8 +1073,8 @@ XS(XS_maybe_next_method) { dMARK; dAX; - SV* self = ST(0); - SV* methcv = __nextcan(aTHX_ self, 0); + SV* const self = ST(0); + SV* const methcv = __nextcan(aTHX_ self, 0); PERL_UNUSED_ARG(cv);