X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/3d8812a2a5ed72332e86e2f36bc5caa37e3e75c0..a770949e9fb75429772c3b99590c5599df3ff999:/mro.c?ds=sidebyside diff --git a/mro.c b/mro.c index 04b3c27..5f7b939 100644 --- a/mro.c +++ b/mro.c @@ -17,7 +17,6 @@ /* =head1 MRO Functions - These functions are related to the method resolution order of perl classes =cut @@ -143,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); @@ -307,19 +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)); - SvIsCOW_on(val); - SvPOK_on(val); - if (HEK_UTF8(key)) - SvUTF8_on(val); - + sv_sethek(val, key); av_push(retval, val); } } @@ -492,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; @@ -502,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; @@ -527,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 ? -(I32)stashname_len : (I32)stashname_len, 0); + svp = hv_fetchhek(PL_isarev, stashhek, 0); isarev = svp ? MUTABLE_HV(*svp) : NULL; if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) @@ -546,6 +532,8 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) /* 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; @@ -634,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) ); + } } } } @@ -678,20 +665,20 @@ 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 ? -(I32)stashname_len : (I32)stashname_len, &PL_sv_yes, 0); + (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes); } /* 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; @@ -708,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) ? -(I32)len : (I32)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); @@ -722,7 +710,7 @@ S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, 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 +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 @@ -777,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; } @@ -961,7 +948,7 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, 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)); + SVfARG(*svp))); (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD); } ++svp; @@ -978,7 +965,8 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, * 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 ? -(I32)len : (I32)len, 0); fetched_isarev=TRUE; @@ -1064,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) { @@ -1320,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 ? -(I32)stashname_len : (I32)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; @@ -1367,6 +1350,8 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) /* 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 @@ -1404,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); @@ -1414,7 +1398,6 @@ Perl_boot_core_mro(pTHX) XS(XS_mro_method_changed_in) { - dVAR; dXSARGS; SV* classname; HV* class_stash;