*/
#include "EXTERN.h"
+#define PERL_IN_MRO_C
#include "perl.h"
struct mro_meta*
=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;
/* 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 */
}
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);
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);
=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;
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);
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);
}
}
}
dVAR;
dXSARGS;
SV* classname;
- SV** svp;
+ HE* he;
HV* isarev;
- char* classname_pv;
- STRLEN classname_len;
AV* ret_array;
PERL_UNUSED_ARG(cv);
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) {
HV* isarev;
char* classname_pv;
STRLEN classname_len;
- SV** svp;
+ HE* he;
PERL_UNUSED_ARG(cv);
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)))
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;
I32 entries;
struct mro_meta* selfmeta;
HV* nmcache;
+ I32 i;
+
+ PERL_UNUSED_ARG(cv);
SP -= items;
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 */
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;
projects / p5sagit/p5-mst-13.2.git / blobdiff