X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/81a2487c2088676b85785de5c132f808748b1a22..2f14ddcd0c64ac3c80bca49bad0af9734d9f6c6b:/mro.c diff --git a/mro.c b/mro.c index 8276795..cb67950 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. @@ -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)); @@ -124,7 +131,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); } @@ -216,7 +223,7 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) assert(HvAUX(stash)); stashhek - = HvAUX(stash)->xhv_name && HvENAME_HEK_NN(stash) + = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash) ? HvENAME_HEK_NN(stash) : HvNAME_HEK(stash); @@ -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); @@ -304,8 +312,7 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) 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); + SvIsCOW_on(val); SvPOK_on(val); if (HEK_UTF8(key)) SvUTF8_on(val); @@ -379,10 +386,9 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) /* =for apidoc mro_get_linear_isa -Returns either C or -C for the given stash, -dependant upon which MRO is in effect -for that stash. The return value is a +Returns the mro linearisation for the given stash. By default, this +will be whatever C returns unless some +other MRO is in effect for the stash. The return value is a read-only AV*. You are responsible for C on the @@ -408,6 +414,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. */ @@ -472,6 +501,7 @@ Perl_mro_isa_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; PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN; @@ -494,7 +524,8 @@ 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_len, 0); + svp = hv_fetch(PL_isarev, stashname, + stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0); isarev = svp ? MUTABLE_HV(*svp) : NULL; if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) @@ -510,6 +541,12 @@ 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); + + /* 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. */ @@ -518,7 +555,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 @@ -531,9 +568,7 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) isa_hashes = (HV *)sv_2mortal((SV *)newHV()); } while((iter = hv_iternext(isarev))) { - I32 len; - const char* const revkey = hv_iterkey(iter, &len); - HV* revstash = gv_stashpvn(revkey, len, 0); + HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0); struct mro_meta* revmeta; if(!revstash) continue; @@ -543,6 +578,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( @@ -596,7 +632,8 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) (void) hv_store( - mroisarev, HEK_KEY(namehek), HEK_LEN(namehek), + mroisarev, HEK_KEY(namehek), + HEK_UTF8(namehek) ? -HEK_LEN(namehek) : HEK_LEN(namehek), &PL_sv_yes, 0 ); } @@ -604,7 +641,7 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) if((SV *)isa != &PL_sv_undef) mro_clean_isarev( isa, HEK_KEY(namehek), HEK_LEN(namehek), - HvMROMETA(revstash)->isa + HvMROMETA(revstash)->isa, (HEK_UTF8(namehek) ? SVf_UTF8 : 0) ); } } @@ -638,36 +675,40 @@ 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_len, &PL_sv_yes, 0); + (void)hv_store(mroisarev, stashname, + 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); + mro_clean_isarev(isa, stashname, stashname_len, meta->isa, + (stashname_utf8 ? SVf_UTF8 : 0) ); } /* 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) + const STRLEN len, HV * const exceptions, 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))) { I32 klen; const char * const key = hv_iterkey(iter, &klen); - if(exceptions && hv_exists(exceptions, key, klen)) continue; - svp = hv_fetch(PL_isarev, key, klen, 0); + if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen)) + continue; + svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0); if(svp) { HV * const isarev = (HV *)*svp; - (void)hv_delete(isarev, name, len, G_DISCARD); - if(!HvARRAY(isarev) || !HvKEYS(isarev)) - (void)hv_delete(PL_isarev, key, klen, 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); } } } @@ -677,11 +718,9 @@ 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 -that is actually being assigned to. C and C are the -full name of the GV. If these last two arguments are omitted, they can be -inferred from C. C can be omitted if C is given. +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 indicate that C has been deleted. @@ -694,23 +733,24 @@ 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 is set to 1 -and C is null. +simply returns. This checked will be skipped if C. =cut */ void Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, - const GV *gv, const char *newname, - I32 newname_len) + const GV * const gv, U32 flags) { + SV *namesv; + HEK **namep; + I32 name_count; HV *stashes; HE* iter; + PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED; assert(stash || oldstash); - assert(gv || newname); - /* Determine the name of the location that stash was assigned to + /* Determine the name(s) of the location that stash was assigned to * or from which oldstash was removed. * * We cannot reliably use the name in oldstash, because it may have @@ -723,19 +763,78 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, * *$globref = *frelp::; * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0) * - * If newname is not null, then we trust that the caller gave us the - * right name. Otherwise, we get it from the gv. But if the gv is not - * in the symbol table, then we just return. We skip that check, - * however, if newname_len is 1 and newname is null. + * So we get it from the gv. But, since the gv may no longer be in the + * symbol table, we check that first. The only reliable way to tell is + * to see whether its stash has an effective name and whether the gv + * resides in that stash under its name. That effective name may be + * different from what gv_fullname4 would use. + * If flags & 1, the caller has asked us to skip the check. */ - if(!newname && gv) { - SV * const namesv = sv_newmortal(); - STRLEN len; - gv_fullname4(namesv, gv, NULL, 0); - if( newname_len != 1 - && gv_fetchsv(namesv, GV_NOADD_NOINIT, SVt_PVGV) != gv ) return; - newname = SvPV_const(namesv, len); - newname_len = len - 2; /* skip trailing :: */ + if(!(flags & 1)) { + SV **svp; + if( + !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) || + !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv), + GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0)) || + *svp != (SV *)gv + ) return; + } + assert(SvOOK(GvSTASH(gv))); + assert(GvNAMELEN(gv)); + assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':'); + assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':'); + name_count = HvAUX(GvSTASH(gv))->xhv_name_count; + if (!name_count) { + name_count = 1; + namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name; + } + else { + namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names; + if (name_count < 0) ++namep, name_count = -name_count - 1; + } + if (name_count == 1) { + if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) { + namesv = GvNAMELEN(gv) == 1 + ? newSVpvs_flags(":", SVs_TEMP) + : newSVpvs_flags("", SVs_TEMP); + } + else { + namesv = sv_2mortal(newSVhek(*namep)); + if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":"); + else sv_catpvs(namesv, "::"); + } + if (GvNAMELEN(gv) != 1) { + sv_catpvn_flags( + namesv, GvNAME(gv), GvNAMELEN(gv) - 2, + /* skip trailing :: */ + GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES + ); + } + } + else { + SV *aname; + namesv = sv_2mortal((SV *)newAV()); + while (name_count--) { + if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)){ + aname = GvNAMELEN(gv) == 1 + ? newSVpvs(":") + : newSVpvs(""); + namep++; + } + else { + aname = newSVhek(*namep++); + if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":"); + else sv_catpvs(aname, "::"); + } + if (GvNAMELEN(gv) != 1) { + sv_catpvn_flags( + aname, GvNAME(gv), GvNAMELEN(gv) - 2, + /* skip trailing :: */ + GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES + ); + } + av_push((AV *)namesv, aname); + } } /* Get a list of all the affected classes. */ @@ -754,7 +853,7 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, stashes = (HV *) sv_2mortal((SV *)newHV()); mro_gather_and_rename( stashes, (HV *) sv_2mortal((SV *)newHV()), - stash, oldstash, newname, newname_len + stash, oldstash, namesv ); /* Once the caches have been wiped on all the classes, call @@ -783,18 +882,19 @@ 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, const char *name, - I32 namlen) + 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); + bool fetched_isarev = FALSE; HV *seen = NULL; HV *isarev = NULL; - SV **svp; + SV **svp = NULL; PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME; @@ -843,35 +943,69 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, /* Update the effective name. */ if(HvENAME_get(oldstash)) { - const HEK * const enamehek = HvENAME_HEK(oldstash); - if(PL_stashcache) - (void) - hv_delete(PL_stashcache, name, namlen, G_DISCARD); - hv_ename_delete(oldstash, name, namlen); - - /* If the name deletion caused a name change, then we 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 of subclasses. We simply delete the latter from - * from PL_isarev, since we still need it. hv_delete mortifies 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, namlen, NULL); - isarev = (HV *)hv_delete(PL_isarev, name, namlen, 0); - } + const HEK * const enamehek = HvENAME_HEK(oldstash); + if(SvTYPE(namesv) == SVt_PVAV) { + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + } + else { + items = 1; + svp = &namesv; + } + while (items--) { + const U32 name_utf8 = SvUTF8(*svp); + STRLEN len; + 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", + *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) { + /* If the name deletion caused a name change, then we + * 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 + * 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); + isarev = (HV *)hv_delete(PL_isarev, name, + name_utf8 ? -(I32)len : (I32)len, 0); + fetched_isarev=TRUE; + } + } + } } } check_stash: if(stash) { - hv_ename_add(stash, name, namlen); + if(SvTYPE(namesv) == SVt_PVAV) { + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + } + else { + items = 1; + svp = &namesv; + } + while (items--) { + const U32 name_utf8 = SvUTF8(*svp); + STRLEN len; + const char *name = SvPVx_const(*svp++, len); + hv_ename_add(stash, name, len, name_utf8); + } /* 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 - * its cached isa linerisation is now stale (the effective name + * 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 * [perl #77358].) @@ -913,19 +1047,51 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, return; /* Add all the subclasses to the big list. */ + if(!fetched_isarev) { + /* If oldstash is not null, then we can use its HvENAME to look up + the isarev hash, since all its subclasses will be listed there. + It will always have an HvENAME. It the HvENAME was removed + above, then fetch_isarev will be true, and this code will not be + reached. + + If oldstash is null, then this is an empty spot with no stash in + it, so subclasses could be listed in isarev hashes belonging to + any of the names, so we have to check all of them. + */ + assert(!oldstash || HvENAME(oldstash)); + if (oldstash) { + /* Extra variable to avoid a compiler warning */ + char * const hvename = HvENAME(oldstash); + fetched_isarev = TRUE; + svp = hv_fetch(PL_isarev, hvename, + HvENAMEUTF8(oldstash) + ? -HvENAMELEN_get(oldstash) + : HvENAMELEN_get(oldstash), 0); + if (svp) isarev = MUTABLE_HV(*svp); + } + else if(SvTYPE(namesv) == SVt_PVAV) { + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + } + else { + items = 1; + svp = &namesv; + } + } if( - isarev - || ( - (svp = hv_fetch(PL_isarev, name, namlen, 0)) - && (isarev = MUTABLE_HV(*svp)) - ) + isarev || !fetched_isarev ) { + while (fetched_isarev || items--) { HE *iter; + + if (!fetched_isarev) { + HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0); + if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue; + } + hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { - I32 len; - const char* const revkey = hv_iterkey(iter, &len); - HV* revstash = gv_stashpvn(revkey, len, 0); + HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0); struct mro_meta * meta; if(!revstash) continue; @@ -940,11 +1106,10 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, ); CLEAR_LINEAR(meta); } - } - if( - (!stash || !HvARRAY(stash)) && (!oldstash || !HvARRAY(oldstash)) - ) return; + if (fetched_isarev) break; + } + } /* This is partly based on code in hv_iternext_flags. We are not call- ing that here, as we want to avoid resetting the hash iterator. */ @@ -971,10 +1136,11 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, if (!isGV(HeVAL(entry))) continue; key = hv_iterkey(entry, &len); - if(len > 1 && key[len-2] == ':' && key[len-1] == ':') { + 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, len, 0) : NULL; + = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL; HV *substash = NULL; /* Avoid main::main::main::... */ @@ -989,23 +1155,46 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, ) { /* Add :: and the key (minus the trailing ::) - to newname. */ - SV *namesv - = newSVpvn_flags(name, namlen, SVs_TEMP); - { - const char *name; - STRLEN namlen; - sv_catpvs(namesv, "::"); - sv_catpvn(namesv, key, len-2); - name = SvPV_const(namesv, namlen); - mro_gather_and_rename( - stashes, seen_stashes, - substash, oldsubstash, name, namlen - ); + to each name. */ + SV *subname; + if(SvTYPE(namesv) == SVt_PVAV) { + SV *aname; + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + subname = sv_2mortal((SV *)newAV()); + while (items--) { + aname = newSVsv(*svp++); + if (len == 1) + sv_catpvs(aname, ":"); + else { + sv_catpvs(aname, "::"); + sv_catpvn_flags( + aname, key, len-2, + HeUTF8(entry) + ? SV_CATUTF8 : SV_CATBYTES + ); + } + av_push((AV *)subname, aname); + } + } + else { + subname = sv_2mortal(newSVsv(namesv)); + if (len == 1) sv_catpvs(subname, ":"); + else { + sv_catpvs(subname, "::"); + sv_catpvn_flags( + subname, key, len-2, + HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES + ); + } } + mro_gather_and_rename( + stashes, seen_stashes, + substash, oldsubstash, subname + ); } - (void)hv_store(seen, key, len, &PL_sv_yes, 0); + (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0); } } } @@ -1031,35 +1220,60 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, if (!isGV(HeVAL(entry))) continue; key = hv_iterkey(entry, &len); - if(len > 1 && key[len-2] == ':' && key[len-1] == ':') { + 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, 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. */ substash = GvHV(HeVAL(entry)); if(substash) { - SV *namesv; - const char *subname; - STRLEN subnamlen; + SV *subname; /* Avoid checking main::main::main::... */ if(substash == stash) continue; /* Add :: and the key (minus the trailing ::) - to newname. */ - namesv - = newSVpvn_flags(name, namlen, SVs_TEMP); - sv_catpvs(namesv, "::"); - sv_catpvn(namesv, key, len-2); - subname = SvPV_const(namesv, subnamlen); + to each name. */ + if(SvTYPE(namesv) == SVt_PVAV) { + SV *aname; + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + subname = sv_2mortal((SV *)newAV()); + while (items--) { + aname = newSVsv(*svp++); + if (len == 1) + sv_catpvs(aname, ":"); + else { + sv_catpvs(aname, "::"); + sv_catpvn_flags( + aname, key, len-2, + HeUTF8(entry) + ? SV_CATUTF8 : SV_CATBYTES + ); + } + av_push((AV *)subname, aname); + } + } + else { + subname = sv_2mortal(newSVsv(namesv)); + if (len == 1) sv_catpvs(subname, ":"); + else { + sv_catpvs(subname, "::"); + sv_catpvn_flags( + subname, key, len-2, + HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES + ); + } + } mro_gather_and_rename( stashes, seen_stashes, - substash, NULL, subname, subnamlen + substash, NULL, subname ); } } @@ -1076,7 +1290,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 @@ -1103,8 +1317,10 @@ 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_len, 0); + SV ** const svp = hv_fetch(PL_isarev, stashname, + stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0); HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL; PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN; @@ -1115,6 +1331,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")) @@ -1130,9 +1349,7 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { - I32 len; - const char* const revkey = hv_iterkey(iter, &len); - HV* const revstash = gv_stashpvn(revkey, len, 0); + HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0); struct mro_meta* mrometa; if(!revstash) continue; @@ -1140,8 +1357,13 @@ 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); } void @@ -1211,8 +1433,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: */