X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mro.c;h=4f850f4ea324c1abda938898d43787999c9a1f1f;hb=869efde7048cf4e4bafcc463f8d4209a63e0d41a;hp=b43bfd016d30e3e4a6e55b9dc14f9fa1fccba2b4;hpb=f58cd3869828b0993f2ad27e1061f23f4c1959bb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mro.c b/mro.c index b43bfd0..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); @@ -531,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); } } } @@ -769,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); @@ -785,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) { @@ -811,7 +817,7 @@ XS(XS_mro_is_universal) HV* isarev; char* classname_pv; STRLEN classname_len; - SV** svp; + HE* he; PERL_UNUSED_ARG(cv); @@ -823,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))) @@ -902,7 +908,7 @@ XS(XS_mro_nextcan) dXSARGS; SV* self = ST(0); const I32 throw_nomethod = SvIVX(ST(1)); - register I32 cxix; + register I32 cxix = cxstack_ix; register const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; HV* selfstash; @@ -919,6 +925,9 @@ XS(XS_mro_nextcan) I32 entries; struct mro_meta* selfmeta; HV* nmcache; + I32 i; + + PERL_UNUSED_ARG(cv); SP -= items; @@ -933,67 +942,68 @@ XS(XS_mro_nextcan) if (!hvname) Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); - cxix = __dopoptosub_at(cxstack, cxstack_ix); - cxix = __dopoptosub_at(ccstack, cxix - 1); /* skip next::method, etc */ - /* This block finds the contextually-enclosing fully-qualified subname, much like looking at (caller($i))[3] until you find a real sub that - isn't ANON, etc */ - for (;;) { - GV* cvgv; - STRLEN fq_subname_len; - - /* we may be in a higher stacklevel, so dig down deeper */ - while (cxix < 0) { - if(top_si->si_type == PERLSI_MAIN) - Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context"); - top_si = top_si->si_prev; - ccstack = top_si->si_cxstack; - cxix = __dopoptosub_at(ccstack, top_si->si_cxix); - } + isn't ANON, etc (also skips over pureperl next::method, etc) */ + for(i = 0; i < 2; i++) { + cxix = __dopoptosub_at(ccstack, cxix); + for (;;) { + GV* cvgv; + STRLEN fq_subname_len; + + /* we may be in a higher stacklevel, so dig down deeper */ + while (cxix < 0) { + if(top_si->si_type == PERLSI_MAIN) + Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context"); + top_si = top_si->si_prev; + ccstack = top_si->si_cxstack; + cxix = __dopoptosub_at(ccstack, top_si->si_cxix); + } - if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB - || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) { - cxix = __dopoptosub_at(ccstack, cxix - 1); - continue; - } + if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB + || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) { + cxix = __dopoptosub_at(ccstack, cxix - 1); + continue; + } - { - const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1); - if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) { - if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) { - cxix = dbcxix; - continue; + { + const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1); + if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) { + if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) { + cxix = dbcxix; + continue; + } } } - } - cvgv = CvGV(ccstack[cxix].blk_sub.cv); + cvgv = CvGV(ccstack[cxix].blk_sub.cv); - if(!isGV(cvgv)) { - cxix = __dopoptosub_at(ccstack, cxix - 1); - continue; - } + if(!isGV(cvgv)) { + cxix = __dopoptosub_at(ccstack, cxix - 1); + continue; + } - /* we found a real sub here */ - sv = sv_2mortal(newSV(0)); + /* we found a real sub here */ + sv = sv_2mortal(newSV(0)); - gv_efullname3(sv, cvgv, NULL); + gv_efullname3(sv, cvgv, NULL); - fq_subname = SvPVX(sv); - fq_subname_len = SvCUR(sv); + fq_subname = SvPVX(sv); + fq_subname_len = SvCUR(sv); - subname = strrchr(fq_subname, ':'); - if(!subname) - Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method"); + subname = strrchr(fq_subname, ':'); + if(!subname) + Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method"); - subname++; - subname_len = fq_subname_len - (subname - fq_subname); - if(subname_len == 8 && strEQ(subname, "__ANON__")) { - cxix = __dopoptosub_at(ccstack, cxix - 1); - continue; + subname++; + subname_len = fq_subname_len - (subname - fq_subname); + if(subname_len == 8 && strEQ(subname, "__ANON__")) { + cxix = __dopoptosub_at(ccstack, cxix - 1); + continue; + } + break; } - break; + cxix--; } /* If we made it to here, we found our context */ @@ -1073,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;