[p5sagit/p5-mst-13.2.git] / ext / mro / mro.xs

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

static AV*
S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level);

static const struct mro_alg c3_alg =
    {S_mro_get_linear_isa_c3, "c3", 2, 0, 0};

/*
=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;

    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 *tails;
        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
		  = S_mro_get_linear_isa_c3(aTHX_ isa_item_stash, level + 1);

		if(items == 0 && AvFILLp(seqs) == -1) {
		    /* Only one parent class. For this case, the C3
		       linearisation is this class followed by the parent's
		       inearisation, so don't bother with the expensive
		       calculation.  */
		    SV **svp;
		    I32 subrv_items = AvFILLp(isa_lin) + 1;
		    SV *const *subrv_p = AvARRAY(isa_lin);

		    /* Hijack the allocated but unused array seqs to be the
		       return value. It's currently mortalised.  */

		    retval = seqs;

		    av_extend(retval, subrv_items);
		    AvFILLp(retval) = subrv_items;
		    svp = AvARRAY(retval);

		    /* First entry is this class.  We happen to make a shared
		       hash key scalar because it's the cheapest and fastest
		       way to do it.  */
		    *svp++ = newSVhek(stashhek);

		    while(subrv_items--) {
			/* These values are unlikely to be shared hash key
			   scalars, so no point in adding code to optimising
			   for a case that is unlikely to be true.
			   (Or prove me wrong and do it.)  */

			SV *const val = *subrv_p++;
			*svp++ = newSVsv(val);
		    }

		    SvREFCNT_inc(retval);

		    goto done;
		}
                av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
            }
        }
        av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
	tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));

        /* 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) {
                SV *errmsg;
                I32 i;

                errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
                                  "current merge results [\n", HEK_KEY(stashhek));
                for (i = 0; i <= av_len(retval); i++) {
                    SV **elem = av_fetch(retval, i, 0);
                    sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
                }
                sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));

                /* we have to do some cleanup before we croak */

                SvREFCNT_dec(retval);
                Safefree(heads);

                Perl_croak(aTHX_ "%"SVf, SVfARG(errmsg));
            }
        }
    }
    else { /* @ISA was undefined or empty */
        /* build a retval containing only ourselves */
        retval = newAV();
        av_push(retval, newSVhek(stashhek));
    }

 done:
    /* 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)));
}


/* 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;
}

MODULE = mro		PACKAGE = mro		PREFIX = mro_

void
mro_get_linear_isa(...)
  PROTOTYPE: $;$
  PREINIT:
    AV* RETVAL;
    HV* class_stash;
    SV* classname;
  PPCODE:
    if(items < 1 || items > 2)
	croak_xs_usage(cv, "classname [, type ]");

    classname = ST(0);
    class_stash = gv_stashsv(classname, 0);

    if(!class_stash) {
        /* No stash exists yet, give them just the classname */
        AV* isalin = newAV();
        av_push(isalin, newSVsv(classname));
        ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
        XSRETURN(1);
    }
    else if(items > 1) {
	const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
	if (!algo)
	    Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
	RETVAL = algo->resolve(aTHX_ class_stash, 0);
    }
    else {
        RETVAL = mro_get_linear_isa(class_stash);
    }
    ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
    sv_2mortal(ST(0));
    XSRETURN(1);

void
mro_set_mro(...)
  PROTOTYPE: $$
  PREINIT:
    SV* classname;
    HV* class_stash;
    struct mro_meta* meta;
  PPCODE:
    if (items != 2)
	croak_xs_usage(cv, "classname, type");

    classname = ST(0);
    class_stash = gv_stashsv(classname, GV_ADD);
    if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
    meta = HvMROMETA(class_stash);

    Perl_mro_set_mro(aTHX_ meta, ST(1));

    XSRETURN_EMPTY;

void
mro_get_mro(...)
  PROTOTYPE: $
  PREINIT:
    SV* classname;
    HV* class_stash;
  PPCODE:
    if (items != 1)
	croak_xs_usage(cv, "classname");

    classname = ST(0);
    class_stash = gv_stashsv(classname, 0);

    if (class_stash) {
        const struct mro_alg *const meta = HvMROMETA(class_stash)->mro_which;
 	ST(0) = newSVpvn_flags(meta->name, meta->length,
			       SVs_TEMP
			       | ((meta->kflags & HVhek_UTF8) ? SVf_UTF8 : 0));
    } else {
      ST(0) = newSVpvn_flags("dfs", 3, SVs_TEMP);
    }
    XSRETURN(1);

void
mro_get_isarev(...)
  PROTOTYPE: $
  PREINIT:
    SV* classname;
    HE* he;
    HV* isarev;
    AV* ret_array;
  PPCODE:
    if (items != 1)
	croak_xs_usage(cv, "classname");

    classname = ST(0);

    he = hv_fetch_ent(PL_isarev, classname, 0, 0);
    isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;

    ret_array = newAV();
    if(isarev) {
        HE* iter;
        hv_iterinit(isarev);
        while((iter = hv_iternext(isarev)))
            av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
    }
    mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));

    PUTBACK;

void
mro_is_universal(...)
  PROTOTYPE: $
  PREINIT:
    SV* classname;
    HV* isarev;
    char* classname_pv;
    STRLEN classname_len;
    HE* he;
  PPCODE:
    if (items != 1)
	croak_xs_usage(cv, "classname");

    classname = ST(0);

    classname_pv = SvPV(classname,classname_len);

    he = hv_fetch_ent(PL_isarev, classname, 0, 0);
    isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;

    if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
        || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
        XSRETURN_YES;
    else
        XSRETURN_NO;


void
mro_invalidate_all_method_caches(...)
  PROTOTYPE: 
  PPCODE:
    if (items != 0)
	croak_xs_usage(cv, "");

    PL_sub_generation++;

    XSRETURN_EMPTY;

void
mro_get_pkg_gen(...)
  PROTOTYPE: $
  PREINIT:
    SV* classname;
    HV* class_stash;
  PPCODE:
    if(items != 1)
	croak_xs_usage(cv, "classname");
    
    classname = ST(0);

    class_stash = gv_stashsv(classname, 0);

    mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
    
    PUTBACK;

void
mro__nextcan(...)
  PREINIT:
    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;
  PPCODE:
    PERL_UNUSED_ARG(cv);

    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_newmortal();

            gv_efullname3(sv, cvgv, NULL);

	    if(SvPOK(sv)) {
		fq_subname = SvPVX(sv);
		fq_subname_len = SvCUR(sv);

		subname = strrchr(fq_subname, ':');
	    } else {
		subname = NULL;
	    }

            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);

    /* has ourselves at the top of the list */
    linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);

    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, sv, MUTABLE_SV(cand_cv), 0);
                mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
                XSRETURN(1);
            }
        }
    }

    (void)hv_store_ent(nmcache, sv, &PL_sv_undef, 0);
    if(throw_nomethod)
        Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
    XSRETURN_EMPTY;

BOOT:
    Perl_mro_register(aTHX_ &c3_alg);
Commit	Line	Data
b2685f0c	1	#include "EXTERN.h"
	2	#include "perl.h"
	3	#include "XSUB.h"
	4
	5	static AV*
	6	S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level);
	7
	8	static const struct mro_alg c3_alg =
	9	{S_mro_get_linear_isa_c3, "c3", 2, 0, 0};
	10
	11	/*
	12	=for apidoc mro_get_linear_isa_c3
	13
	14	Returns the C3 linearization of @ISA
	15	the given stash. The return value is a read-only AV*.
	16	C<level> should be 0 (it is used internally in this
	17	function's recursion).
	18
	19	You are responsible for C<SvREFCNT_inc()> on the
	20	return value if you plan to store it anywhere
	21	semi-permanently (otherwise it might be deleted
	22	out from under you the next time the cache is
	23	invalidated).
	24
	25	=cut
	26	*/
	27
	28	static AV*
	29	S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
	30	{
	31	AV* retval;
	32	GV** gvp;
	33	GV* gv;
	34	AV* isa;
	35	const HEK* stashhek;
	36	struct mro_meta* meta;
	37
	38	assert(HvAUX(stash));
	39
	40	stashhek = HvNAME_HEK(stash);
	41	if (!stashhek)
	42	Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
	43
	44	if (level > 100)
	45	Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
	46	HEK_KEY(stashhek));
	47
	48	meta = HvMROMETA(stash);
	49
	50	/* return cache if valid */
	51	if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) {
	52	return retval;
	53	}
	54
	55	/* not in cache, make a new one */
	56
	57	gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
	58	isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
	59
	60	/* For a better idea how the rest of this works, see the much clearer
	61	pure perl version in Algorithm::C3 0.01:
	62	http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
	63	(later versions go about it differently than this code for speed reasons)
	64	*/
65
66	if(isa && AvFILLp(isa) >= 0) {
67	SV** seqs_ptr;
68	I32 seqs_items;
b0413f46	69	HV *tails;
b2685f0c	70	AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
	71	I32* heads;
	72
	73	/* This builds @seqs, which is an array of arrays.
	74	The members of @seqs are the MROs of
	75	the members of @ISA, followed by @ISA itself.
	76	*/
	77	I32 items = AvFILLp(isa) + 1;
	78	SV** isa_ptr = AvARRAY(isa);
	79	while(items--) {
	80	SV* const isa_item = *isa_ptr++;
	81	HV* const isa_item_stash = gv_stashsv(isa_item, 0);
	82	if(!isa_item_stash) {
	83	/* if no stash, make a temporary fake MRO
	84	containing just itself */
	85	AV* const isa_lin = newAV();
	86	av_push(isa_lin, newSVsv(isa_item));
	87	av_push(seqs, MUTABLE_SV(isa_lin));
	88	}
	89	else {
	90	/* recursion */
	91	AV* const isa_lin
	92	= S_mro_get_linear_isa_c3(aTHX_ isa_item_stash, level + 1);
b0413f46	93
a18d9f20	94	if(items == 0 && AvFILLp(seqs) == -1) {
b0413f46	95	/* Only one parent class. For this case, the C3
	96	linearisation is this class followed by the parent's
	97	inearisation, so don't bother with the expensive
	98	calculation. */
	99	SV **svp;
	100	I32 subrv_items = AvFILLp(isa_lin) + 1;
	101	SV const subrv_p = AvARRAY(isa_lin);
	102
	103	/* Hijack the allocated but unused array seqs to be the
	104	return value. It's currently mortalised. */
	105
	106	retval = seqs;
	107
	108	av_extend(retval, subrv_items);
	109	AvFILLp(retval) = subrv_items;
	110	svp = AvARRAY(retval);
	111
	112	/* First entry is this class. We happen to make a shared
	113	hash key scalar because it's the cheapest and fastest
	114	way to do it. */
	115	*svp++ = newSVhek(stashhek);
	116
	117	while(subrv_items--) {
	118	/* These values are unlikely to be shared hash key
	119	scalars, so no point in adding code to optimising
	120	for a case that is unlikely to be true.
	121	(Or prove me wrong and do it.) */
	122
	123	SV const val = subrv_p++;
	124	*svp++ = newSVsv(val);
	125	}
	126
	127	SvREFCNT_inc(retval);
	128
	129	goto done;
	130	}
b2685f0c	131	av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
	132	}
	133	}
	134	av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
b0413f46	135	tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
b2685f0c	136
	137	/* This builds "heads", which as an array of integer array
	138	indices, one per seq, which point at the virtual "head"
	139	of the seq (initially zero) */
	140	Newxz(heads, AvFILLp(seqs)+1, I32);
	141
	142	/* This builds %tails, which has one key for every class
	143	mentioned in the tail of any sequence in @seqs (tail meaning
	144	everything after the first class, the "head"). The value
	145	is how many times this key appears in the tails of @seqs.
	146	*/
	147	seqs_ptr = AvARRAY(seqs);
	148	seqs_items = AvFILLp(seqs) + 1;
	149	while(seqs_items--) {
	150	AV const seq = MUTABLE_AV(seqs_ptr++);
	151	I32 seq_items = AvFILLp(seq);
	152	if(seq_items > 0) {
	153	SV** seq_ptr = AvARRAY(seq) + 1;
	154	while(seq_items--) {
	155	SV* const seqitem = *seq_ptr++;
	156	/* LVALUE fetch will create a new undefined SV if necessary
	157	*/
	158	HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
	159	if(he) {
	160	SV* const val = HeVAL(he);
	161	/* This will increment undef to 1, which is what we
	162	want for a newly created entry. */
	163	sv_inc(val);
	164	}
	165	}
	166	}
	167	}
	168
	169	/* Initialize retval to build the return value in */
	170	retval = newAV();
	171	av_push(retval, newSVhek(stashhek)); /* us first */
	172
	173	/* This loop won't terminate until we either finish building
	174	the MRO, or get an exception. */
	175	while(1) {
	176	SV* cand = NULL;
	177	SV* winner = NULL;
	178	int s;
	179
	180	/* "foreach $seq (@seqs)" */
	181	SV** const avptr = AvARRAY(seqs);
	182	for(s = 0; s <= AvFILLp(seqs); s++) {
	183	SV** svp;
	184	AV * const seq = MUTABLE_AV(avptr[s]);
	185	SV* seqhead;
	186	if(!seq) continue; /* skip empty seqs */
	187	svp = av_fetch(seq, heads[s], 0);
	188	seqhead = svp; / seqhead = head of this seq */
	189	if(!winner) {
	190	HE* tail_entry;
	191	SV* val;
	192	/* if we haven't found a winner for this round yet,
	193	and this seqhead is not in tails (or the count
	194	for it in tails has dropped to zero), then this
	195	seqhead is our new winner, and is added to the
	196	final MRO immediately */
	197	cand = seqhead;
	198	if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
	199	&& (val = HeVAL(tail_entry))
200	&& (SvIVX(val) > 0))
201	continue;
202	winner = newSVsv(cand);
203	av_push(retval, winner);
204	/* note however that even when we find a winner,
205	we continue looping over @seqs to do housekeeping */
206	}
207	if(!sv_cmp(seqhead, winner)) {
208	/* Once we have a winner (including the iteration
209	where we first found him), inc the head ptr
210	for any seq which had the winner as a head,
211	NULL out any seq which is now empty,
212	and adjust tails for consistency */
213
214	const int new_head = ++heads[s];
215	if(new_head > AvFILLp(seq)) {
216	SvREFCNT_dec(avptr[s]);
217	avptr[s] = NULL;
218	}
219	else {
220	HE* tail_entry;
221	SV* val;
222	/* Because we know this new seqhead used to be
223	a tail, we can assume it is in tails and has
224	a positive value, which we need to dec */
225	svp = av_fetch(seq, new_head, 0);
226	seqhead = *svp;
227	tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
228	val = HeVAL(tail_entry);
229	sv_dec(val);
230	}
231	}
232	}
233
234	/* if we found no candidates, we are done building the MRO.
235	!cand means no seqs have any entries left to check */
236	if(!cand) {
237	Safefree(heads);
238	break;
239	}
240
241	/* If we had candidates, but nobody won, then the @ISA
242	hierarchy is not C3-incompatible */
243	if(!winner) {
b1172053	244	SV *errmsg;
	245	I32 i;
	246
	247	errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
	248	"current merge results [\n", HEK_KEY(stashhek));
	249	for (i = 0; i <= av_len(retval); i++) {
	250	SV **elem = av_fetch(retval, i, 0);
	251	sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
	252	}
	253	sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
	254
b2685f0c	255	/* we have to do some cleanup before we croak */
	256
	257	SvREFCNT_dec(retval);
	258	Safefree(heads);
	259
b1172053	260	Perl_croak(aTHX_ "%"SVf, SVfARG(errmsg));
b2685f0c	261	}
	262	}
	263	}
	264	else { /* @ISA was undefined or empty */
	265	/* build a retval containing only ourselves */
	266	retval = newAV();
	267	av_push(retval, newSVhek(stashhek));
	268	}
	269
b0413f46	270	done:
b2685f0c	271	/* we don't want anyone modifying the cache entry but us,
	272	and we do so by replacing it completely */
	273	SvREADONLY_on(retval);
	274
	275	return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
	276	MUTABLE_SV(retval)));
b2685f0c	277	}
	278
	279
	280	/* These two are static helpers for next::method and friends,
	281	and re-implement a bunch of the code from pp_caller() in
	282	a more efficient manner for this particular usage.
	283	*/
	284
	285	static I32
	286	__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
	287	I32 i;
	288	for (i = startingblock; i >= 0; i--) {
	289	if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
	290	}
	291	return i;
	292	}
	293
1e9bd118	294	MODULE = mro PACKAGE = mro PREFIX = mro_
b2685f0c	295
b2685f0c	296	void
1e9bd118	297	mro_get_linear_isa(...)
	298	PROTOTYPE: $;$
	299	PREINIT:
	300	AV* RETVAL;
	301	HV* class_stash;
	302	SV* classname;
	303	PPCODE:
	304	if(items < 1 \|\| items > 2)
	305	croak_xs_usage(cv, "classname [, type ]");
	306
	307	classname = ST(0);
	308	class_stash = gv_stashsv(classname, 0);
	309
	310	if(!class_stash) {
	311	/* No stash exists yet, give them just the classname */
	312	AV* isalin = newAV();
	313	av_push(isalin, newSVsv(classname));
	314	ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
	315	XSRETURN(1);
	316	}
	317	else if(items > 1) {
	318	const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
	319	if (!algo)
	320	Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
	321	RETVAL = algo->resolve(aTHX_ class_stash, 0);
	322	}
	323	else {
	324	RETVAL = mro_get_linear_isa(class_stash);
	325	}
	326	ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
	327	sv_2mortal(ST(0));
	328	XSRETURN(1);
	329
	330	void
	331	mro_set_mro(...)
	332	PROTOTYPE: $$
	333	PREINIT:
	334	SV* classname;
1e9bd118	335	HV* class_stash;
	336	struct mro_meta* meta;
	337	PPCODE:
	338	if (items != 2)
	339	croak_xs_usage(cv, "classname, type");
	340
	341	classname = ST(0);
	342	class_stash = gv_stashsv(classname, GV_ADD);
	343	if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
	344	meta = HvMROMETA(class_stash);
	345
	346	Perl_mro_set_mro(aTHX_ meta, ST(1));
	347
	348	XSRETURN_EMPTY;
	349
	350	void
	351	mro_get_mro(...)
	352	PROTOTYPE: $
	353	PREINIT:
	354	SV* classname;
	355	HV* class_stash;
	356	PPCODE:
	357	if (items != 1)
	358	croak_xs_usage(cv, "classname");
	359
	360	classname = ST(0);
	361	class_stash = gv_stashsv(classname, 0);
	362
fbb5a95c	363	if (class_stash) {
	364	const struct mro_alg *const meta = HvMROMETA(class_stash)->mro_which;
	365	ST(0) = newSVpvn_flags(meta->name, meta->length,
	366	SVs_TEMP
	367	\| ((meta->kflags & HVhek_UTF8) ? SVf_UTF8 : 0));
	368	} else {
	369	ST(0) = newSVpvn_flags("dfs", 3, SVs_TEMP);
	370	}
1e9bd118	371	XSRETURN(1);
	372
	373	void
	374	mro_get_isarev(...)
	375	PROTOTYPE: $
	376	PREINIT:
	377	SV* classname;
	378	HE* he;
	379	HV* isarev;
	380	AV* ret_array;
	381	PPCODE:
	382	if (items != 1)
	383	croak_xs_usage(cv, "classname");
	384
	385	classname = ST(0);
	386
	387	he = hv_fetch_ent(PL_isarev, classname, 0, 0);
	388	isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
	389
	390	ret_array = newAV();
	391	if(isarev) {
	392	HE* iter;
	393	hv_iterinit(isarev);
	394	while((iter = hv_iternext(isarev)))
	395	av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
	396	}
	397	mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
	398
	399	PUTBACK;
	400
	401	void
	402	mro_is_universal(...)
	403	PROTOTYPE: $
	404	PREINIT:
	405	SV* classname;
	406	HV* isarev;
	407	char* classname_pv;
	408	STRLEN classname_len;
	409	HE* he;
	410	PPCODE:
	411	if (items != 1)
	412	croak_xs_usage(cv, "classname");
	413
	414	classname = ST(0);
	415
	416	classname_pv = SvPV(classname,classname_len);
	417
	418	he = hv_fetch_ent(PL_isarev, classname, 0, 0);
	419	isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
	420
	421	if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
	422	\|\| (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
	423	XSRETURN_YES;
	424	else
	425	XSRETURN_NO;
	426
	427
	428	void
a4133167	429	mro_invalidate_all_method_caches(...)
1e9bd118	430	PROTOTYPE:
	431	PPCODE:
	432	if (items != 0)
	433	croak_xs_usage(cv, "");
	434
	435	PL_sub_generation++;
	436
	437	XSRETURN_EMPTY;
	438
	439	void
	440	mro_get_pkg_gen(...)
	441	PROTOTYPE: $
	442	PREINIT:
	443	SV* classname;
	444	HV* class_stash;
	445	PPCODE:
	446	if(items != 1)
	447	croak_xs_usage(cv, "classname");
	448
	449	classname = ST(0);
	450
	451	class_stash = gv_stashsv(classname, 0);
	452
	453	mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
	454
	455	PUTBACK;
	456
	457	void
	458	mro__nextcan(...)
b2685f0c	459	PREINIT:
	460	SV* self = ST(0);
	461	const I32 throw_nomethod = SvIVX(ST(1));
	462	register I32 cxix = cxstack_ix;
	463	register const PERL_CONTEXT *ccstack = cxstack;
	464	const PERL_SI *top_si = PL_curstackinfo;
	465	HV* selfstash;
	466	SV *stashname;
	467	const char *fq_subname;
	468	const char *subname;
	469	STRLEN stashname_len;
	470	STRLEN subname_len;
	471	SV* sv;
	472	GV** gvp;
	473	AV* linear_av;
	474	SV** linear_svp;
	475	const char *hvname;
	476	I32 entries;
	477	struct mro_meta* selfmeta;
	478	HV* nmcache;
	479	I32 i;
	480	PPCODE:
	481	PERL_UNUSED_ARG(cv);
	482
	483	if(sv_isobject(self))
	484	selfstash = SvSTASH(SvRV(self));
	485	else
	486	selfstash = gv_stashsv(self, GV_ADD);
	487
	488	assert(selfstash);
	489
	490	hvname = HvNAME_get(selfstash);
	491	if (!hvname)
	492	Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
	493
	494	/* This block finds the contextually-enclosing fully-qualified subname,
	495	much like looking at (caller($i))[3] until you find a real sub that
	496	isn't ANON, etc (also skips over pureperl next::method, etc) */
	497	for(i = 0; i < 2; i++) {
	498	cxix = __dopoptosub_at(ccstack, cxix);
	499	for (;;) {
	500	GV* cvgv;
	501	STRLEN fq_subname_len;
	502
	503	/* we may be in a higher stacklevel, so dig down deeper */
	504	while (cxix < 0) {
	505	if(top_si->si_type == PERLSI_MAIN)
	506	Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
	507	top_si = top_si->si_prev;
	508	ccstack = top_si->si_cxstack;
	509	cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
	510	}
	511
	512	if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
	513	\|\| (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
	514	cxix = __dopoptosub_at(ccstack, cxix - 1);
	515	continue;
	516	}
	517
	518	{
	519	const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
	520	if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
	521	if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
	522	cxix = dbcxix;
523	continue;
524	}
525	}
526	}
527
528	cvgv = CvGV(ccstack[cxix].blk_sub.cv);
529
530	if(!isGV(cvgv)) {
531	cxix = __dopoptosub_at(ccstack, cxix - 1);
532	continue;
533	}
534
535	/* we found a real sub here */
8e234d89	536	sv = sv_newmortal();
b2685f0c	537
	538	gv_efullname3(sv, cvgv, NULL);
	539
9c1314f0	540	if(SvPOK(sv)) {
	541	fq_subname = SvPVX(sv);
	542	fq_subname_len = SvCUR(sv);
	543
	544	subname = strrchr(fq_subname, ':');
	545	} else {
	546	subname = NULL;
	547	}
b2685f0c	548
b2685f0c	549	if(!subname)
	550	Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
	551
	552	subname++;
	553	subname_len = fq_subname_len - (subname - fq_subname);
	554	if(subname_len == 8 && strEQ(subname, "__ANON__")) {
	555	cxix = __dopoptosub_at(ccstack, cxix - 1);
	556	continue;
	557	}
	558	break;
	559	}
	560	cxix--;
	561	}
	562
	563	/* If we made it to here, we found our context */
	564
	565	/* Initialize the next::method cache for this stash
	566	if necessary */
	567	selfmeta = HvMROMETA(selfstash);
	568	if(!(nmcache = selfmeta->mro_nextmethod)) {
	569	nmcache = selfmeta->mro_nextmethod = newHV();
	570	}
	571	else { /* Use the cached coderef if it exists */
	572	HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
	573	if (cache_entry) {
	574	SV* const val = HeVAL(cache_entry);
	575	if(val == &PL_sv_undef) {
	576	if(throw_nomethod)
	577	Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
	578	XSRETURN_EMPTY;
	579	}
	580	mXPUSHs(newRV_inc(val));
	581	XSRETURN(1);
	582	}
	583	}
	584
	585	/* beyond here is just for cache misses, so perf isn't as critical */
	586
	587	stashname_len = subname - fq_subname - 2;
	588	stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
	589
	590	/* has ourselves at the top of the list */
	591	linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);
	592
	593	linear_svp = AvARRAY(linear_av);
	594	entries = AvFILLp(linear_av) + 1;
	595
	596	/* Walk down our MRO, skipping everything up
	597	to the contextually enclosing class */
	598	while (entries--) {
	599	SV * const linear_sv = *linear_svp++;
	600	assert(linear_sv);
	601	if(sv_eq(linear_sv, stashname))
	602	break;
	603	}
	604
	605	/* Now search the remainder of the MRO for the
	606	same method name as the contextually enclosing
	607	method */
	608	if(entries > 0) {
	609	while (entries--) {
	610	SV * const linear_sv = *linear_svp++;
	611	HV* curstash;
	612	GV* candidate;
613	CV* cand_cv;
614
615	assert(linear_sv);
616	curstash = gv_stashsv(linear_sv, FALSE);
617
618	if (!curstash) {
619	if (ckWARN(WARN_SYNTAX))
620	Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
621	(void*)linear_sv, hvname);
622	continue;
623	}
624
625	assert(curstash);
626
627	gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
628	if (!gvp) continue;
629
630	candidate = *gvp;
631	assert(candidate);
632
633	if (SvTYPE(candidate) != SVt_PVGV)
634	gv_init(candidate, curstash, subname, subname_len, TRUE);
635
636	/* Notably, we only look for real entries, not method cache
637	entries, because in C3 the method cache of a parent is not
638	valid for the child */
639	if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
640	SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
59d8e2ce	641	(void)hv_store_ent(nmcache, sv, MUTABLE_SV(cand_cv), 0);
b2685f0c	642	mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
	643	XSRETURN(1);
	644	}
	645	}
	646	}
	647
59d8e2ce	648	(void)hv_store_ent(nmcache, sv, &PL_sv_undef, 0);
b2685f0c	649	if(throw_nomethod)
	650	Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
	651	XSRETURN_EMPTY;
	652
	653	BOOT:
	654	Perl_mro_register(aTHX_ &c3_alg);