X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c682ebef862f40c7b7ed8a6175ecb457b9981787..c43e874320ac47cebbfc6fdd4c881214d39128ad:/mro.c diff --git a/mro.c b/mro.c index c7f7538..5f7b939 100644 --- a/mro.c +++ b/mro.c @@ -1,7 +1,7 @@ /* mro.c * * Copyright (c) 2007 Brandon L Black - * Copyright (c) 2007, 2008 Larry Wall and others + * Copyright (c) 2007, 2008, 2009, 2010, 2011 Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -17,7 +17,6 @@ /* =head1 MRO Functions - These functions are related to the method resolution order of perl classes =cut @@ -114,6 +113,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)); @@ -124,7 +130,7 @@ Perl_mro_register(pTHX_ const struct mro_alg *mro) { if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL, mro->name, mro->length, mro->kflags, HV_FETCH_ISSTORE, wrapper, mro->hash)) { - SvREFCNT_dec(wrapper); + SvREFCNT_dec_NN(wrapper); Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() " "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags); } @@ -136,6 +142,7 @@ Perl_mro_meta_init(pTHX_ HV* stash) struct mro_meta* newmeta; PERL_ARGS_ASSERT_MRO_META_INIT; + PERL_UNUSED_CONTEXT; assert(HvAUX(stash)); assert(!(HvAUX(stash)->xhv_mro_meta)); Newxz(newmeta, 1, struct mro_meta); @@ -179,6 +186,8 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param) newmeta->isa = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param)); + newmeta->super = NULL; + return newmeta; } @@ -224,8 +233,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); @@ -259,10 +269,11 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) /* foreach(@ISA) */ while (items--) { - SV* const sv = *svp++; + SV* const sv = *svp ? *svp : &PL_sv_undef; HV* const basestash = gv_stashsv(sv, 0); SV *const *subrv_p; I32 subrv_items; + svp++; if (!basestash) { /* if no stash exists for this @ISA member, @@ -296,20 +307,7 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) 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); - + sv_sethek(val, key); av_push(retval, val); } } @@ -407,6 +405,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. */ @@ -459,7 +480,6 @@ by the C magic, should not need to invoke directly. void Perl_mro_isa_changed_in(pTHX_ HV* stash) { - dVAR; HV* isarev; AV* linear_mro; HE* iter; @@ -469,9 +489,9 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) struct mro_meta * meta; HV *isa = NULL; + const HEK * const stashhek = HvENAME_HEK(stash); const char * const stashname = HvENAME_get(stash); const STRLEN stashname_len = HvENAMELEN_get(stash); - const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0; PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN; @@ -494,8 +514,7 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) /* Wipe the global method cache if this package is UNIVERSAL or one of its parents */ - svp = hv_fetch(PL_isarev, stashname, - stashname_utf8 ? -stashname_len : stashname_len, 0); + svp = hv_fetchhek(PL_isarev, stashhek, 0); isarev = svp ? MUTABLE_HV(*svp) : NULL; if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) @@ -511,6 +530,14 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) /* wipe next::method cache too */ if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod); + /* Changes to @ISA might turn overloading on */ + HvAMAGIC_on(stash); + /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */ + HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; + + /* DESTROY can be cached in SvSTASH. */ + if (!SvOBJECT(stash)) SvSTASH(stash) = NULL; + /* Iterate the isarev (classes that are our children), wiping out their linearization, method and isa caches and upating PL_isarev. */ @@ -519,7 +546,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 @@ -542,6 +569,7 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) revmeta->cache_gen++; if(revmeta->mro_nextmethod) hv_clear(revmeta->mro_nextmethod); + if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL; (void) hv_store( @@ -594,18 +622,17 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) it doesn't exist. */ (void) - hv_store( - mroisarev, HEK_KEY(namehek), - HEK_UTF8(namehek) ? -HEK_LEN(namehek) : HEK_LEN(namehek), - &PL_sv_yes, 0 - ); + hv_storehek(mroisarev, namehek, &PL_sv_yes); } - if((SV *)isa != &PL_sv_undef) + if ((SV *)isa != &PL_sv_undef) { + assert(namehek); mro_clean_isarev( isa, HEK_KEY(namehek), HEK_LEN(namehek), - HvMROMETA(revstash)->isa, (HEK_UTF8(namehek) ? SVf_UTF8 : 0) + HvMROMETA(revstash)->isa, HEK_HASH(namehek), + HEK_UTF8(namehek) ); + } } } } @@ -638,26 +665,26 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) save time by not making two calls to the common HV code for the case where it doesn't exist. */ - (void)hv_store(mroisarev, stashname, - stashname_utf8 ? -stashname_len : stashname_len, &PL_sv_yes, 0); + (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes); } - /* 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) ); + HEK_HASH(stashhek), HEK_UTF8(stashhek)); } /* Deletes name from all the isarev entries listed in isa */ STATIC void S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, - const STRLEN len, HV * const exceptions, U32 flags) + const STRLEN len, HV * const exceptions, U32 hash, + U32 flags) { HE* iter; 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 +695,8 @@ 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_common(isarev, NULL, name, len, flags, + G_DISCARD|HV_DELETE, NULL, hash); if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev)) (void)hv_delete(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, G_DISCARD); @@ -681,8 +709,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 +724,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 */ @@ -737,8 +765,7 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, SV **svp; if( !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) || - !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv), - GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0)) || + !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) || *svp != (SV *)gv ) return; } @@ -845,12 +872,12 @@ 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) { - register XPVHV* xhv; - register HE *entry; + XPVHV* xhv; + HE *entry; I32 riter = -1; I32 items = 0; const bool stash_had_name = stash && HvENAME(stash); @@ -918,9 +945,13 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, while (items--) { const U32 name_utf8 = SvUTF8(*svp); STRLEN len; - const char *name = SvPVx_const(*svp++, len); - if(PL_stashcache) - (void)hv_delete(PL_stashcache, name, name_utf8 ? -len : len, G_DISCARD); + const char *name = SvPVx_const(*svp, len); + if(PL_stashcache) { + DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"SVf"'\n", + SVfARG(*svp))); + (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD); + } + ++svp; hv_ename_delete(oldstash, name, len, name_utf8); if (!fetched_isarev) { @@ -928,15 +959,16 @@ 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. */ if(HvENAME_HEK(oldstash) != enamehek) { if(meta->isa && HvARRAY(meta->isa)) - mro_clean_isarev(meta->isa, name, len, 0, name_utf8); + mro_clean_isarev(meta->isa, name, len, 0, 0, + name_utf8 ? HVhek_UTF8 : 0); isarev = (HV *)hv_delete(PL_isarev, name, - name_utf8 ? -len : len, 0); + name_utf8 ? -(I32)len : (I32)len, 0); fetched_isarev=TRUE; } } @@ -963,7 +995,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 @@ -1020,12 +1052,9 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, assert(!oldstash || HvENAME(oldstash)); if (oldstash) { /* Extra variable to avoid a compiler warning */ - char * const hvename = HvENAME(oldstash); + const HEK * const hvename = HvENAME_HEK(oldstash); fetched_isarev = TRUE; - svp = hv_fetch(PL_isarev, hvename, - HvENAMEUTF8(oldstash) - ? -HvENAMELEN_get(oldstash) - : HvENAMELEN_get(oldstash), 0); + svp = hv_fetchhek(PL_isarev, hvename, 0); if (svp) isarev = MUTABLE_HV(*svp); } else if(SvTYPE(namesv) == SVt_PVAV) { @@ -1087,21 +1116,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::... */ @@ -1109,7 +1136,7 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, if( ( - stashentry && *stashentry + stashentry && *stashentry && isGV(*stashentry) && (substash = GvHV(*stashentry)) ) || (oldsubstash && HvENAME_get(oldsubstash)) @@ -1131,7 +1158,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 +1172,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 +1182,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 +1200,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 +1241,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 +1255,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 +1278,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 @@ -1280,10 +1305,8 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) { const char * const stashname = HvENAME_get(stash); const STRLEN stashname_len = HvENAMELEN_get(stash); - const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0; - SV ** const svp = hv_fetch(PL_isarev, stashname, - stashname_utf8 ? -stashname_len : stashname_len, 0); + SV ** const svp = hv_fetchhek(PL_isarev, HvENAME_HEK(stash), 0); HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL; PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN; @@ -1294,6 +1317,9 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) /* Inc the package generation, since a local method changed */ HvMROMETA(stash)->pkg_gen++; + /* DESTROY can be cached in SvSTASH. */ + if (!SvOBJECT(stash)) SvSTASH(stash) = NULL; + /* If stash is UNIVERSAL, or one of UNIVERSAL's parents, invalidate all method caches globally */ if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) @@ -1317,8 +1343,15 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) mrometa->cache_gen++; if(mrometa->mro_nextmethod) hv_clear(mrometa->mro_nextmethod); + if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL; } } + + /* The method change may be due to *{$package . "::()"} = \&nil; in + overload.pm. */ + HvAMAGIC_on(stash); + /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */ + HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; } void @@ -1356,7 +1389,6 @@ XS(XS_mro_method_changed_in); void Perl_boot_core_mro(pTHX) { - dVAR; static const char file[] = __FILE__; Perl_mro_register(aTHX_ &dfs_alg); @@ -1366,7 +1398,6 @@ Perl_boot_core_mro(pTHX) XS(XS_mro_method_changed_in) { - dVAR; dXSARGS; SV* classname; HV* class_stash; @@ -1388,8 +1419,8 @@ XS(XS_mro_method_changed_in) * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */