X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c682ebef862f40c7b7ed8a6175ecb457b9981787..9fef6a0d04f0ff51fd6182e37d56e3439312a445:/mro.c diff --git a/mro.c b/mro.c index c7f7538..94be41c 100644 --- a/mro.c +++ b/mro.c @@ -114,6 +114,13 @@ Perl_mro_get_from_name(pTHX_ SV *name) { return INT2PTR(const struct mro_alg *, SvUVX(*data)); } +/* +=for apidoc mro_register +Registers a custom mro plugin. See L for details. + +=cut +*/ + void Perl_mro_register(pTHX_ const struct mro_alg *mro) { SV *wrapper = newSVuv(PTR2UV(mro)); @@ -224,8 +231,9 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); if (level > 100) - Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", - HEK_KEY(stashhek)); + Perl_croak(aTHX_ + "Recursive inheritance detected in package '%"HEKf"'", + HEKfARG(stashhek)); meta = HvMROMETA(stash); @@ -407,6 +415,29 @@ Perl_mro_get_linear_isa(pTHX_ HV *stash) Perl_croak(aTHX_ "panic: invalid MRO!"); isa = meta->mro_which->resolve(aTHX_ stash, 0); + if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */ + SV * const namesv = + (HvENAME(stash)||HvNAME(stash)) + ? newSVhek(HvENAME_HEK(stash) + ? HvENAME_HEK(stash) + : HvNAME_HEK(stash)) + : NULL; + + if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv))) + { + AV * const old = isa; + SV **svp; + SV **ovp = AvARRAY(old); + SV * const * const oend = ovp + AvFILLp(old) + 1; + isa = (AV *)sv_2mortal((SV *)newAV()); + av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1); + *AvARRAY(isa) = namesv; + svp = AvARRAY(isa)+1; + while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++); + } + else SvREFCNT_dec(namesv); + } + if (!meta->isa) { HV *const isa_hash = newHV(); /* Linearisation didn't build it for us, so do it here. */ @@ -495,7 +526,7 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) is UNIVERSAL or one of its parents */ svp = hv_fetch(PL_isarev, stashname, - stashname_utf8 ? -stashname_len : stashname_len, 0); + stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0); isarev = svp ? MUTABLE_HV(*svp) : NULL; if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) @@ -519,7 +550,7 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) /* We have to iterate through isarev twice to avoid a chicken and * egg problem: if A inherits from B and both are in isarev, A might - * be processed before B and use B’s previous linearisation. + * be processed before B and use B's previous linearisation. */ /* First iteration: Wipe everything, but stash away the isa hashes @@ -639,10 +670,10 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) case where it doesn't exist. */ (void)hv_store(mroisarev, stashname, - stashname_utf8 ? -stashname_len : stashname_len, &PL_sv_yes, 0); + stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, &PL_sv_yes, 0); } - /* Delete our name from our former parents’ isarevs. */ + /* Delete our name from our former parents' isarevs. */ if(isa && HvARRAY(isa)) mro_clean_isarev(isa, stashname, stashname_len, meta->isa, (stashname_utf8 ? SVf_UTF8 : 0) ); @@ -657,7 +688,7 @@ S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV; - /* Delete our name from our former parents’ isarevs. */ + /* Delete our name from our former parents' isarevs. */ if(isa && HvARRAY(isa) && hv_iterinit(isa)) { SV **svp; while((iter = hv_iternext(isa))) { @@ -668,7 +699,7 @@ S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0); if(svp) { HV * const isarev = (HV *)*svp; - (void)hv_delete(isarev, name, (flags & SVf_UTF8) ? -len : len, G_DISCARD); + (void)hv_delete(isarev, name, (flags & SVf_UTF8) ? -(I32)len : (I32)len, G_DISCARD); if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev)) (void)hv_delete(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, G_DISCARD); @@ -681,8 +712,8 @@ S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, =for apidoc mro_package_moved Call this function to signal to a stash that it has been assigned to -another spot in the stash hierarchy. C is the stash that has been -assigned. C is the stash it replaces, if any. C is the glob +another spot in the stash hierarchy. C is the stash that has been +assigned. C is the stash it replaces, if any. C is the glob that is actually being assigned to. This can also be called with a null first argument to @@ -696,7 +727,7 @@ It also sets the effective names (C) on all the stashes as appropriate. If the C is present and is not in the symbol table, then this function -simply returns. This checked will be skipped if C. +simply returns. This checked will be skipped if C. =cut */ @@ -845,7 +876,7 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, } } -void +STATIC void S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, HV *stash, HV *oldstash, SV *namesv) { @@ -920,7 +951,7 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, STRLEN len; const char *name = SvPVx_const(*svp++, len); if(PL_stashcache) - (void)hv_delete(PL_stashcache, name, name_utf8 ? -len : len, G_DISCARD); + (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD); hv_ename_delete(oldstash, name, len, name_utf8); if (!fetched_isarev) { @@ -928,7 +959,7 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, * are not going to call mro_isa_changed_in with this * name (and not at all if it has become anonymous) so * we need to delete old isarev entries here, both - * those in the superclasses and this class’s own list + * those in the superclasses and this class's own list * of subclasses. We simply delete the latter from * PL_isarev, since we still need it. hv_delete morti- * fies it for us, so sv_2mortal is not necessary. */ @@ -936,7 +967,7 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, if(meta->isa && HvARRAY(meta->isa)) mro_clean_isarev(meta->isa, name, len, 0, name_utf8); isarev = (HV *)hv_delete(PL_isarev, name, - name_utf8 ? -len : len, 0); + name_utf8 ? -(I32)len : (I32)len, 0); fetched_isarev=TRUE; } } @@ -963,7 +994,7 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, /* Add it to the big list if it needs * mro_isa_changed_in called on it. That happens if it was * detached from the symbol table (so it had no HvENAME) before - * being assigned to the spot named by the ‘name’ variable, because + * being assigned to the spot named by the 'name' variable, because * its cached isa linearisation is now stale (the effective name * having changed), and subclasses will then use that cache when * mro_package_moved calls mro_isa_changed_in. (See @@ -1087,21 +1118,19 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, /* Iterate through the entries in this list */ for(; entry; entry = HeNEXT(entry)) { - SV* keysv; const char* key; - STRLEN len; + I32 len; /* If this entry is not a glob, ignore it. Try the next. */ if (!isGV(HeVAL(entry))) continue; - keysv = hv_iterkeysv(entry); - key = SvPV_const(keysv, len); + key = hv_iterkey(entry, &len); if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') || (len == 1 && key[0] == ':')) { HV * const oldsubstash = GvHV(HeVAL(entry)); SV ** const stashentry - = stash ? hv_fetch(stash, key, SvUTF8(keysv) ? -len : len, 0) : NULL; + = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL; HV *substash = NULL; /* Avoid main::main::main::... */ @@ -1131,7 +1160,7 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, sv_catpvs(aname, "::"); sv_catpvn_flags( aname, key, len-2, - SvUTF8(keysv) + HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES ); } @@ -1145,7 +1174,7 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, sv_catpvs(subname, "::"); sv_catpvn_flags( subname, key, len-2, - SvUTF8(keysv) ? SV_CATUTF8 : SV_CATBYTES + HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES ); } } @@ -1155,7 +1184,7 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, ); } - (void)hv_store(seen, key, SvUTF8(keysv) ? -len : len, &PL_sv_yes, 0); + (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0); } } } @@ -1173,23 +1202,21 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, /* Iterate through the entries in this list */ for(; entry; entry = HeNEXT(entry)) { - SV* keysv; const char* key; - STRLEN len; + I32 len; /* If this entry is not a glob, ignore it. Try the next. */ if (!isGV(HeVAL(entry))) continue; - keysv = hv_iterkeysv(entry); - key = SvPV_const(keysv, len); + key = hv_iterkey(entry, &len); if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') || (len == 1 && key[0] == ':')) { HV *substash; /* If this entry was seen when we iterated through the oldstash, skip it. */ - if(seen && hv_exists(seen, key, SvUTF8(keysv) ? -len : len)) continue; + if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue; /* We get here only if this stash has no corresponding entry in the stash being replaced. */ @@ -1216,7 +1243,7 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, sv_catpvs(aname, "::"); sv_catpvn_flags( aname, key, len-2, - SvUTF8(keysv) + HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES ); } @@ -1230,7 +1257,7 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, sv_catpvs(subname, "::"); sv_catpvn_flags( subname, key, len-2, - SvUTF8(keysv) ? SV_CATUTF8 : SV_CATBYTES + HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES ); } } @@ -1253,7 +1280,7 @@ of the given stash, so that they might notice the changes in this one. Ideally, all instances of C in -perl source outside of C should be +perl source outside of F should be replaced by calls to this. Perl automatically handles most of the common @@ -1283,7 +1310,7 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0; SV ** const svp = hv_fetch(PL_isarev, stashname, - stashname_utf8 ? -stashname_len : stashname_len, 0); + stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0); HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL; PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;