X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mro.c;h=4f850f4ea324c1abda938898d43787999c9a1f1f;hb=869efde7048cf4e4bafcc463f8d4209a63e0d41a;hp=8d98fdceebd3c3a68397c5e0f61d088b334936eb;hpb=70cd14a10b623c21342f84d4826106411378add8;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/mro.c b/mro.c
index 8d98fdc..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);
@@ -411,8 +421,10 @@ AV*
 Perl_mro_get_linear_isa(pTHX_ HV *stash)
 {
     struct mro_meta* meta;
+
     assert(stash);
-    assert(HvAUX(stash));
+    if(!SvOOK(stash))
+        Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
 
     meta = HvMROMETA(stash);
     if(meta->mro_which == MRO_DFS) {
@@ -444,12 +456,16 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
     SV** svp;
     I32 items;
     bool is_universal;
+    struct mro_meta * meta;
 
     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");
+
     /* wipe out the cached linearizations for this stash */
-    struct mro_meta * const meta = HvMROMETA(stash);
+    meta = HvMROMETA(stash);
     SvREFCNT_dec((SV*)meta->mro_linear_dfs);
     SvREFCNT_dec((SV*)meta->mro_linear_c3);
     meta->mro_linear_dfs = NULL;
@@ -525,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);
             }
         }
     }
@@ -577,6 +593,9 @@ Perl_mro_method_changed_in(pTHX_ HV *stash)
     SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
     HV * const isarev = svp ? (HV*)*svp : NULL;
 
+    if(!stashname)
+        Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
+
     /* Inc the package generation, since a local method changed */
     HvMROMETA(stash)->pkg_gen++;
 
@@ -622,187 +641,6 @@ __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
     return i;
 }
 
-STATIC SV*
-__nextcan(pTHX_ SV* self, I32 throw_nomethod)
-{
-    register I32 cxix;
-    register const PERL_CONTEXT *ccstack = cxstack;
-    const PERL_SI *top_si = PL_curstackinfo;
-    HV* selfstash;
-    SV *stashname;
-    const char *fq_subname;
-    const char *subname;
-    STRLEN stashname_len;
-    STRLEN subname_len;
-    SV* sv;
-    GV** gvp;
-    AV* linear_av;
-    SV** linear_svp;
-    const char *hvname;
-    I32 items;
-    struct mro_meta* selfmeta;
-    HV* nmcache;
-
-    if(sv_isobject(self))
-        selfstash = SvSTASH(SvRV(self));
-    else
-        selfstash = gv_stashsv(self, 0);
-
-    assert(selfstash);
-
-    hvname = HvNAME_get(selfstash);
-    if (!hvname)
-        Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
-
-    cxix = __dopoptosub_at(cxstack, cxstack_ix);
-
-    /* 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);
-        }
-
-        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;
-                }
-            }
-        }
-
-        cvgv = CvGV(ccstack[cxix].blk_sub.cv);
-
-        if(!isGV(cvgv)) {
-            cxix = __dopoptosub_at(ccstack, cxix - 1);
-            continue;
-        }
-
-        /* we found a real sub here */
-        sv = sv_2mortal(newSV(0));
-
-        gv_efullname3(sv, cvgv, NULL);
-
-        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++;
-        subname_len = fq_subname_len - (subname - fq_subname);
-        if(subname_len == 8 && strEQ(subname, "__ANON__")) {
-            cxix = __dopoptosub_at(ccstack, cxix - 1);
-            continue;
-        }
-        break;
-    }
-
-    /* If we made it to here, we found our context */
-
-    /* Initialize the next::method cache for this stash
-       if necessary */
-    selfmeta = HvMROMETA(selfstash);
-    if(!(nmcache = selfmeta->mro_nextmethod)) {
-        nmcache = selfmeta->mro_nextmethod = newHV();
-    }
-    else { /* Use the cached coderef if it exists */
-	HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
-	if (cache_entry) {
-	    SV* const val = HeVAL(cache_entry);
-	    if(val == &PL_sv_undef) {
-		if(throw_nomethod)
-		    Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
-	    }
-	    return val;
-	}
-    }
-
-    /* beyond here is just for cache misses, so perf isn't as critical */
-
-    stashname_len = subname - fq_subname - 2;
-    stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
-
-    linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
-
-    linear_svp = AvARRAY(linear_av);
-    items = AvFILLp(linear_av) + 1;
-
-    /* Walk down our MRO, skipping everything up
-       to the contextually enclosing class */
-    while (items--) {
-        SV * const linear_sv = *linear_svp++;
-        assert(linear_sv);
-        if(sv_eq(linear_sv, stashname))
-            break;
-    }
-
-    /* Now search the remainder of the MRO for the
-       same method name as the contextually enclosing
-       method */
-    if(items > 0) {
-        while (items--) {
-            SV * const linear_sv = *linear_svp++;
-	    HV* curstash;
-	    GV* candidate;
-	    CV* cand_cv;
-
-            assert(linear_sv);
-            curstash = gv_stashsv(linear_sv, FALSE);
-
-            if (!curstash) {
-                if (ckWARN(WARN_SYNTAX))
-                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
-                        (void*)linear_sv, hvname);
-                continue;
-            }
-
-            assert(curstash);
-
-            gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
-            if (!gvp) continue;
-
-            candidate = *gvp;
-            assert(candidate);
-
-            if (SvTYPE(candidate) != SVt_PVGV)
-                gv_init(candidate, curstash, subname, subname_len, TRUE);
-
-            /* Notably, we only look for real entries, not method cache
-               entries, because in C3 the method cache of a parent is not
-               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);
-                return (SV*)cand_cv;
-            }
-        }
-    }
-
-    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);
-    return &PL_sv_undef;
-}
-
 #include "XSUB.h"
 
 XS(XS_mro_get_linear_isa);
@@ -813,9 +651,7 @@ XS(XS_mro_is_universal);
 XS(XS_mro_invalidate_method_caches);
 XS(XS_mro_method_changed_in);
 XS(XS_mro_get_pkg_gen);
-XS(XS_next_can);
-XS(XS_next_method);
-XS(XS_maybe_next_method);
+XS(XS_mro_nextcan);
 
 void
 Perl_boot_core_mro(pTHX)
@@ -831,9 +667,7 @@ Perl_boot_core_mro(pTHX)
     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
     newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
-    newXS("next::can", XS_next_can, file);
-    newXS("next::method", XS_next_method, file);
-    newXS("maybe::next::method", XS_maybe_next_method, file);
+    newXS("mro::_nextcan", XS_mro_nextcan, file);
 }
 
 XS(XS_mro_get_linear_isa) {
@@ -945,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);
@@ -961,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) {
@@ -987,7 +817,7 @@ XS(XS_mro_is_universal)
     HV* isarev;
     char* classname_pv;
     STRLEN classname_len;
-    SV** svp;
+    HE* he;
 
     PERL_UNUSED_ARG(cv);
 
@@ -999,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)))
@@ -1072,55 +902,198 @@ XS(XS_mro_get_pkg_gen)
     return;
 }
 
-XS(XS_next_can)
+XS(XS_mro_nextcan)
 {
     dVAR;
     dXSARGS;
-    SV* const self = ST(0);
-    SV* const methcv = __nextcan(aTHX_ self, 0);
+    SV* self = ST(0);
+    const I32 throw_nomethod = SvIVX(ST(1));
+    register I32 cxix = cxstack_ix;
+    register const PERL_CONTEXT *ccstack = cxstack;
+    const PERL_SI *top_si = PL_curstackinfo;
+    HV* selfstash;
+    SV *stashname;
+    const char *fq_subname;
+    const char *subname;
+    STRLEN stashname_len;
+    STRLEN subname_len;
+    SV* sv;
+    GV** gvp;
+    AV* linear_av;
+    SV** linear_svp;
+    const char *hvname;
+    I32 entries;
+    struct mro_meta* selfmeta;
+    HV* nmcache;
+    I32 i;
 
     PERL_UNUSED_ARG(cv);
-    PERL_UNUSED_VAR(items);
 
-    if(methcv == &PL_sv_undef) {
-        ST(0) = &PL_sv_undef;
+    SP -= items;
+
+    if(sv_isobject(self))
+        selfstash = SvSTASH(SvRV(self));
+    else
+        selfstash = gv_stashsv(self, 0);
+
+    assert(selfstash);
+
+    hvname = HvNAME_get(selfstash);
+    if (!hvname)
+        Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
+
+    /* 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 (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;
+            }
+
+            {
+                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);
+
+            if(!isGV(cvgv)) {
+                cxix = __dopoptosub_at(ccstack, cxix - 1);
+                continue;
+            }
+
+            /* we found a real sub here */
+            sv = sv_2mortal(newSV(0));
+
+            gv_efullname3(sv, cvgv, NULL);
+
+            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++;
+            subname_len = fq_subname_len - (subname - fq_subname);
+            if(subname_len == 8 && strEQ(subname, "__ANON__")) {
+                cxix = __dopoptosub_at(ccstack, cxix - 1);
+                continue;
+            }
+            break;
+        }
+        cxix--;
     }
-    else {
-        ST(0) = sv_2mortal(newRV_inc(methcv));
+
+    /* If we made it to here, we found our context */
+
+    /* Initialize the next::method cache for this stash
+       if necessary */
+    selfmeta = HvMROMETA(selfstash);
+    if(!(nmcache = selfmeta->mro_nextmethod)) {
+        nmcache = selfmeta->mro_nextmethod = newHV();
+    }
+    else { /* Use the cached coderef if it exists */
+	HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
+	if (cache_entry) {
+	    SV* const val = HeVAL(cache_entry);
+	    if(val == &PL_sv_undef) {
+		if(throw_nomethod)
+		    Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
+                XSRETURN_EMPTY;
+	    }
+	    XPUSHs(sv_2mortal(newRV_inc(val)));
+            XSRETURN(1);
+	}
     }
 
-    XSRETURN(1);
-}
+    /* beyond here is just for cache misses, so perf isn't as critical */
 
-XS(XS_next_method)
-{
-    dMARK;
-    dAX;
-    SV* const self = ST(0);
-    SV* const methcv = __nextcan(aTHX_ self, 1);
+    stashname_len = subname - fq_subname - 2;
+    stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
 
-    PERL_UNUSED_ARG(cv);
+    linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
 
-    PL_markstack_ptr++;
-    call_sv(methcv, GIMME_V);
-}
+    linear_svp = AvARRAY(linear_av);
+    entries = AvFILLp(linear_av) + 1;
 
-XS(XS_maybe_next_method)
-{
-    dMARK;
-    dAX;
-    SV* const self = ST(0);
-    SV* const methcv = __nextcan(aTHX_ self, 0);
+    /* Walk down our MRO, skipping everything up
+       to the contextually enclosing class */
+    while (entries--) {
+        SV * const linear_sv = *linear_svp++;
+        assert(linear_sv);
+        if(sv_eq(linear_sv, stashname))
+            break;
+    }
 
-    PERL_UNUSED_ARG(cv);
+    /* Now search the remainder of the MRO for the
+       same method name as the contextually enclosing
+       method */
+    if(entries > 0) {
+        while (entries--) {
+            SV * const linear_sv = *linear_svp++;
+	    HV* curstash;
+	    GV* candidate;
+	    CV* cand_cv;
 
-    if(methcv == &PL_sv_undef) {
-        ST(0) = &PL_sv_undef;
-        XSRETURN(1);
+            assert(linear_sv);
+            curstash = gv_stashsv(linear_sv, FALSE);
+
+            if (!curstash) {
+                if (ckWARN(WARN_SYNTAX))
+                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
+                        (void*)linear_sv, hvname);
+                continue;
+            }
+
+            assert(curstash);
+
+            gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
+            if (!gvp) continue;
+
+            candidate = *gvp;
+            assert(candidate);
+
+            if (SvTYPE(candidate) != SVt_PVGV)
+                gv_init(candidate, curstash, subname, subname_len, TRUE);
+
+            /* Notably, we only look for real entries, not method cache
+               entries, because in C3 the method cache of a parent is not
+               valid for the child */
+            if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
+                SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
+                (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
+                XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
+                XSRETURN(1);
+            }
+        }
     }
 
-    PL_markstack_ptr++;
-    call_sv(methcv, GIMME_V);
+    (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;
 }
 
 /*