X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mro.c;h=4f850f4ea324c1abda938898d43787999c9a1f1f;hb=869efde7048cf4e4bafcc463f8d4209a63e0d41a;hp=01461b145ae369ffbf09b5a64cff368df760f2a5;hpb=5be5c7a687aa37f2ea9dec7988eb57cad1f1ec24;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mro.c b/mro.c index 01461b1..4f850f4 100644 --- a/mro.c +++ b/mro.c @@ -21,6 +21,7 @@ These functions are related to the method resolution order of perl classes */ #include "EXTERN.h" +#define PERL_IN_MRO_C #include "perl.h" struct mro_meta* @@ -83,8 +84,8 @@ invalidated). =cut */ -AV* -Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) +static AV* +S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) { AV* retval; GV** gvp; @@ -113,7 +114,7 @@ Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) /* not in cache, make a new one */ - retval = newAV(); + retval = (AV*)sv_2mortal((SV *)newAV()); av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */ /* fetch our @ISA */ @@ -146,7 +147,10 @@ Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) } else { /* otherwise, recurse into ourselves for the MRO - of this @ISA member, and append their MRO to ours */ + of this @ISA member, and append their MRO to ours. + The recursive call could throw an exception, which + has memory management implications here, hence the use of + the mortal. */ const AV *const subrv = mro_get_linear_isa_dfs(basestash, level + 1); @@ -156,13 +160,19 @@ Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level) while(subrv_items--) { SV *const subsv = *subrv_p++; if(!hv_exists_ent(stored, subsv, 0)) { - hv_store_ent(stored, subsv, &PL_sv_undef, 0); + (void)hv_store_ent(stored, subsv, &PL_sv_undef, 0); av_push(retval, newSVsv(subsv)); } } } } + /* now that we're past the exception dangers, grab our own reference to + the AV we're about to use for the result. The reference owned by the + mortals' stack will be released soon, so everything will balance. */ + SvREFCNT_inc_simple_void_NN(retval); + SvTEMP_off(retval); + /* we don't want anyone modifying the cache entry but us, and we do so by replacing it completely */ SvREADONLY_on(retval); @@ -188,8 +198,8 @@ invalidated). =cut */ -AV* -Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) +static AV* +S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) { AV* retval; GV** gvp; @@ -281,7 +291,7 @@ Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) 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); + (void)hv_store_ent(tails, seqitem, newSViv(1), 0); } else { SV* const val = HeVAL(he); @@ -448,10 +458,8 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) bool is_universal; struct mro_meta * meta; - const char * const stashname = stash ? HvNAME_get(stash) : NULL; - const STRLEN stashname_len = stash ? HvNAMELEN_get(stash) : 0; - - if(!stash) return; + const char * const stashname = HvNAME_get(stash); + const STRLEN stashname_len = HvNAMELEN_get(stash); if(!stashname) Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table"); @@ -533,14 +541,14 @@ 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. */ - hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0); + (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0); if(isarev) { hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { I32 revkeylen; char* const revkey = hv_iterkey(iter, &revkeylen); - hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0); + (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0); } } } @@ -771,10 +779,8 @@ XS(XS_mro_get_isarev) dVAR; dXSARGS; SV* classname; - SV** svp; + HE* he; HV* isarev; - char* classname_pv; - STRLEN classname_len; AV* ret_array; PERL_UNUSED_ARG(cv); @@ -787,10 +793,8 @@ XS(XS_mro_get_isarev) SP -= items; - classname_pv = SvPV_nolen(classname); - classname_len = strlen(classname_pv); - svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0); - isarev = svp ? (HV*)*svp : NULL; + he = hv_fetch_ent(PL_isarev, classname, 0, 0); + isarev = he ? (HV*)HeVAL(he) : NULL; ret_array = newAV(); if(isarev) { @@ -813,7 +817,7 @@ XS(XS_mro_is_universal) HV* isarev; char* classname_pv; STRLEN classname_len; - SV** svp; + HE* he; PERL_UNUSED_ARG(cv); @@ -825,8 +829,8 @@ XS(XS_mro_is_universal) classname_pv = SvPV_nolen(classname); classname_len = strlen(classname_pv); - svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0); - isarev = svp ? (HV*)*svp : NULL; + he = hv_fetch_ent(PL_isarev, classname, 0, 0); + isarev = he ? (HV*)HeVAL(he) : NULL; if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL")) || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) @@ -1079,14 +1083,14 @@ XS(XS_mro_nextcan) valid for the child */ if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { SvREFCNT_inc_simple_void_NN((SV*)cand_cv); - hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0); + (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0); XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv))); XSRETURN(1); } } } - hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0); + (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0); if(throw_nomethod) Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); XSRETURN_EMPTY;