Proper pluggable Method Resolution Orders. 'c3' is now implemented outside the

core, in ext/mro/mro.xs. Also move mro::_nextcan() to mro.xs. It needs direct
access to S_mro_get_linear_isa_c3(), and nothing on CPAN calls it, except via
methods defined in mro.pm. Hence all users already require mro;

1 files changed, 0 insertions, 442 deletions

diff --git a/mro.c b/mro.c
index 63ab230371..98981d0360 100644
--- a/mro.c
+++ b/mro.c
@@ -27,21 +27,9 @@ These functions are related to the method resolution order of perl classes
 #define PERL_IN_MRO_C
 #include "perl.h"
 
-struct mro_alg {
-    AV *(*resolve)(pTHX_ HV* stash, U32 level);
-    const char *name;
-    U16 length;
-    U16	kflags;	/* For the hash API - set HVhek_UTF8 if name is UTF-8 */
-    U32 hash; /* or 0 */
-};
-
 static const struct mro_alg dfs_alg =
     {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
 
-static const struct mro_alg c3_alg =
-    {S_mro_get_linear_isa_c3, "c3", 2, 0, 0};
-
-
 SV *
 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
 			  const struct mro_alg *const which)
@@ -357,225 +345,6 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
 }
 
 /*
-=for apidoc mro_get_linear_isa_c3
-
-Returns the C3 linearization of @ISA
-the given stash.  The return value is a read-only AV*.
-C<level> should be 0 (it is used internally in this
-function's recursion).
-
-You are responsible for C<SvREFCNT_inc()> on the
-return value if you plan to store it anywhere
-semi-permanently (otherwise it might be deleted
-out from under you the next time the cache is
-invalidated).
-
-=cut
-*/
-
-static AV*
-S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
-{
-    AV* retval;
-    GV** gvp;
-    GV* gv;
-    AV* isa;
-    const HEK* stashhek;
-    struct mro_meta* meta;
-
-    PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
-    assert(HvAUX(stash));
-
-    stashhek = HvNAME_HEK(stash);
-    if (!stashhek)
-      Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
-
-    if (level > 100)
-        Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
-		   HEK_KEY(stashhek));
-
-    meta = HvMROMETA(stash);
-
-    /* return cache if valid */
-    if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) {
-        return retval;
-    }
-
-    /* not in cache, make a new one */
-
-    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
-    isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
-
-    /* For a better idea how the rest of this works, see the much clearer
-       pure perl version in Algorithm::C3 0.01:
-       http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
-       (later versions go about it differently than this code for speed reasons)
-    */
-
-    if(isa && AvFILLp(isa) >= 0) {
-        SV** seqs_ptr;
-        I32 seqs_items;
-        HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
-        AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
-        I32* heads;
-
-        /* This builds @seqs, which is an array of arrays.
-           The members of @seqs are the MROs of
-           the members of @ISA, followed by @ISA itself.
-        */
-        I32 items = AvFILLp(isa) + 1;
-        SV** isa_ptr = AvARRAY(isa);
-        while(items--) {
-            SV* const isa_item = *isa_ptr++;
-            HV* const isa_item_stash = gv_stashsv(isa_item, 0);
-            if(!isa_item_stash) {
-                /* if no stash, make a temporary fake MRO
-                   containing just itself */
-                AV* const isa_lin = newAV();
-                av_push(isa_lin, newSVsv(isa_item));
-                av_push(seqs, MUTABLE_SV(isa_lin));
-            }
-            else {
-                /* recursion */
-                AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
-                av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
-            }
-        }
-        av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
-
-        /* This builds "heads", which as an array of integer array
-           indices, one per seq, which point at the virtual "head"
-           of the seq (initially zero) */
-        Newxz(heads, AvFILLp(seqs)+1, I32);
-
-        /* This builds %tails, which has one key for every class
-           mentioned in the tail of any sequence in @seqs (tail meaning
-           everything after the first class, the "head").  The value
-           is how many times this key appears in the tails of @seqs.
-        */
-        seqs_ptr = AvARRAY(seqs);
-        seqs_items = AvFILLp(seqs) + 1;
-        while(seqs_items--) {
-            AV *const seq = MUTABLE_AV(*seqs_ptr++);
-            I32 seq_items = AvFILLp(seq);
-            if(seq_items > 0) {
-                SV** seq_ptr = AvARRAY(seq) + 1;
-                while(seq_items--) {
-                    SV* const seqitem = *seq_ptr++;
-		    /* LVALUE fetch will create a new undefined SV if necessary
-		     */
-                    HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
-                    if(he) {
-                        SV* const val = HeVAL(he);
-			/* This will increment undef to 1, which is what we
-			   want for a newly created entry.  */
-                        sv_inc(val);
-                    }
-                }
-            }
-        }
-
-        /* Initialize retval to build the return value in */
-        retval = newAV();
-        av_push(retval, newSVhek(stashhek)); /* us first */
-
-        /* This loop won't terminate until we either finish building
-           the MRO, or get an exception. */
-        while(1) {
-            SV* cand = NULL;
-            SV* winner = NULL;
-            int s;
-
-            /* "foreach $seq (@seqs)" */
-            SV** const avptr = AvARRAY(seqs);
-            for(s = 0; s <= AvFILLp(seqs); s++) {
-                SV** svp;
-                AV * const seq = MUTABLE_AV(avptr[s]);
-		SV* seqhead;
-                if(!seq) continue; /* skip empty seqs */
-                svp = av_fetch(seq, heads[s], 0);
-                seqhead = *svp; /* seqhead = head of this seq */
-                if(!winner) {
-		    HE* tail_entry;
-		    SV* val;
-                    /* if we haven't found a winner for this round yet,
-                       and this seqhead is not in tails (or the count
-                       for it in tails has dropped to zero), then this
-                       seqhead is our new winner, and is added to the
-                       final MRO immediately */
-                    cand = seqhead;
-                    if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
-                       && (val = HeVAL(tail_entry))
-                       && (SvIVX(val) > 0))
-                           continue;
-                    winner = newSVsv(cand);
-                    av_push(retval, winner);
-                    /* note however that even when we find a winner,
-                       we continue looping over @seqs to do housekeeping */
-                }
-                if(!sv_cmp(seqhead, winner)) {
-                    /* Once we have a winner (including the iteration
-                       where we first found him), inc the head ptr
-                       for any seq which had the winner as a head,
-                       NULL out any seq which is now empty,
-                       and adjust tails for consistency */
-
-                    const int new_head = ++heads[s];
-                    if(new_head > AvFILLp(seq)) {
-                        SvREFCNT_dec(avptr[s]);
-                        avptr[s] = NULL;
-                    }
-                    else {
-			HE* tail_entry;
-			SV* val;
-                        /* Because we know this new seqhead used to be
-                           a tail, we can assume it is in tails and has
-                           a positive value, which we need to dec */
-                        svp = av_fetch(seq, new_head, 0);
-                        seqhead = *svp;
-                        tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
-                        val = HeVAL(tail_entry);
-                        sv_dec(val);
-                    }
-                }
-            }
-
-            /* if we found no candidates, we are done building the MRO.
-               !cand means no seqs have any entries left to check */
-            if(!cand) {
-                Safefree(heads);
-                break;
-            }
-
-            /* If we had candidates, but nobody won, then the @ISA
-               hierarchy is not C3-incompatible */
-            if(!winner) {
-                /* we have to do some cleanup before we croak */
-
-                SvREFCNT_dec(retval);
-                Safefree(heads);
-
-                Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
-                    "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
-            }
-        }
-    }
-    else { /* @ISA was undefined or empty */
-        /* build a retval containing only ourselves */
-        retval = newAV();
-        av_push(retval, newSVhek(stashhek));
-    }
-
-    /* we don't want anyone modifying the cache entry but us,
-       and we do so by replacing it completely */
-    SvREADONLY_on(retval);
-
-    return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
-						MUTABLE_SV(retval)));
-    return retval;
-}
-
-/*
 =for apidoc mro_get_linear_isa
 
 Returns either C<mro_get_linear_isa_c3> or
@@ -809,20 +578,6 @@ Perl_mro_method_changed_in(pTHX_ HV *stash)
     }
 }
 
-/* These two are static helpers for next::method and friends,
-   and re-implement a bunch of the code from pp_caller() in
-   a more efficient manner for this particular usage.
-*/
-
-STATIC I32
-__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
-    I32 i;
-    for (i = startingblock; i >= 0; i--) {
-        if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
-    }
-    return i;
-}
-
 #include "XSUB.h"
 
 XS(XS_mro_get_linear_isa);
@@ -833,7 +588,6 @@ 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_mro_nextcan);
 
 void
 Perl_boot_core_mro(pTHX)
@@ -842,7 +596,6 @@ Perl_boot_core_mro(pTHX)
     static const char file[] = __FILE__;
 
     Perl_mro_register(aTHX_ &dfs_alg);
-    Perl_mro_register(aTHX_ &c3_alg);
 
     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
@@ -852,7 +605,6 @@ 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("mro::_nextcan", XS_mro_nextcan, file);
 }
 
 XS(XS_mro_get_linear_isa) {
@@ -1060,200 +812,6 @@ XS(XS_mro_get_pkg_gen)
     return;
 }
 
-XS(XS_mro_nextcan)
-{
-    dVAR;
-    dXSARGS;
-    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);
-
-    SP -= items;
-
-    if(sv_isobject(self))
-        selfstash = SvSTASH(SvRV(self));
-    else
-        selfstash = gv_stashsv(self, GV_ADD);
-
-    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--;
-    }
-
-    /* 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;
-	    }
-	    mXPUSHs(newRV_inc(val));
-            XSRETURN(1);
-	}
-    }
-
-    /* beyond here is just for cache misses, so perf isn't as critical */
-
-    stashname_len = subname - fq_subname - 2;
-    stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
-
-    linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
-
-    linear_svp = AvARRAY(linear_av);
-    entries = AvFILLp(linear_av) + 1;
-
-    /* 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;
-    }
-
-    /* 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;
-
-            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(MUTABLE_SV(cand_cv));
-                (void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0);
-                mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
-                XSRETURN(1);
-            }
-        }
-    }
-
-    (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;
-}
-
 /*
  * Local variables:
  * c-indentation-style: bsd