[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* 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
		  = S_mro_get_linear_isa_c3(aTHX_ 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) {
                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));
    }

    /* 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_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_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);

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

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;
69	HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
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);
93	av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
94	}
95	}
96	av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
97
98	/* This builds "heads", which as an array of integer array
99	indices, one per seq, which point at the virtual "head"
100	of the seq (initially zero) */
101	Newxz(heads, AvFILLp(seqs)+1, I32);
102
103	/* This builds %tails, which has one key for every class
104	mentioned in the tail of any sequence in @seqs (tail meaning
105	everything after the first class, the "head"). The value
106	is how many times this key appears in the tails of @seqs.
107	*/
108	seqs_ptr = AvARRAY(seqs);
109	seqs_items = AvFILLp(seqs) + 1;
110	while(seqs_items--) {
111	AV const seq = MUTABLE_AV(seqs_ptr++);
112	I32 seq_items = AvFILLp(seq);
113	if(seq_items > 0) {
114	SV** seq_ptr = AvARRAY(seq) + 1;
115	while(seq_items--) {
116	SV* const seqitem = *seq_ptr++;
117	/* LVALUE fetch will create a new undefined SV if necessary
118	*/
119	HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
120	if(he) {
121	SV* const val = HeVAL(he);
122	/* This will increment undef to 1, which is what we
123	want for a newly created entry. */
124	sv_inc(val);
125	}
126	}
127	}
128	}
129
130	/* Initialize retval to build the return value in */
131	retval = newAV();
132	av_push(retval, newSVhek(stashhek)); /* us first */
133
134	/* This loop won't terminate until we either finish building
135	the MRO, or get an exception. */
136	while(1) {
137	SV* cand = NULL;
138	SV* winner = NULL;
139	int s;
140
141	/* "foreach $seq (@seqs)" */
142	SV** const avptr = AvARRAY(seqs);
143	for(s = 0; s <= AvFILLp(seqs); s++) {
144	SV** svp;
145	AV * const seq = MUTABLE_AV(avptr[s]);
146	SV* seqhead;
147	if(!seq) continue; /* skip empty seqs */
148	svp = av_fetch(seq, heads[s], 0);
149	seqhead = svp; / seqhead = head of this seq */
150	if(!winner) {
151	HE* tail_entry;
152	SV* val;
153	/* if we haven't found a winner for this round yet,
154	and this seqhead is not in tails (or the count
155	for it in tails has dropped to zero), then this
156	seqhead is our new winner, and is added to the
157	final MRO immediately */
158	cand = seqhead;
159	if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
160	&& (val = HeVAL(tail_entry))
161	&& (SvIVX(val) > 0))
162	continue;
163	winner = newSVsv(cand);
164	av_push(retval, winner);
165	/* note however that even when we find a winner,
166	we continue looping over @seqs to do housekeeping */
167	}
168	if(!sv_cmp(seqhead, winner)) {
169	/* Once we have a winner (including the iteration
170	where we first found him), inc the head ptr
171	for any seq which had the winner as a head,
172	NULL out any seq which is now empty,
173	and adjust tails for consistency */
174
175	const int new_head = ++heads[s];
176	if(new_head > AvFILLp(seq)) {
177	SvREFCNT_dec(avptr[s]);
178	avptr[s] = NULL;
179	}
180	else {
181	HE* tail_entry;
182	SV* val;
183	/* Because we know this new seqhead used to be
184	a tail, we can assume it is in tails and has
185	a positive value, which we need to dec */
186	svp = av_fetch(seq, new_head, 0);
187	seqhead = *svp;
188	tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
189	val = HeVAL(tail_entry);
190	sv_dec(val);
191	}
192	}
193	}
194
195	/* if we found no candidates, we are done building the MRO.
196	!cand means no seqs have any entries left to check */
197	if(!cand) {
198	Safefree(heads);
199	break;
200	}
201
202	/* If we had candidates, but nobody won, then the @ISA
203	hierarchy is not C3-incompatible */
204	if(!winner) {
b1172053	205	SV *errmsg;
	206	I32 i;
	207
	208	errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
	209	"current merge results [\n", HEK_KEY(stashhek));
	210	for (i = 0; i <= av_len(retval); i++) {
	211	SV **elem = av_fetch(retval, i, 0);
	212	sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
	213	}
	214	sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
	215
b2685f0c	216	/* we have to do some cleanup before we croak */
	217
	218	SvREFCNT_dec(retval);
	219	Safefree(heads);
	220
b1172053	221	Perl_croak(aTHX_ "%"SVf, SVfARG(errmsg));
b2685f0c	222	}
	223	}
	224	}
	225	else { /* @ISA was undefined or empty */
	226	/* build a retval containing only ourselves */
	227	retval = newAV();
	228	av_push(retval, newSVhek(stashhek));
	229	}
	230
	231	/* we don't want anyone modifying the cache entry but us,
	232	and we do so by replacing it completely */
	233	SvREADONLY_on(retval);
	234
	235	return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
	236	MUTABLE_SV(retval)));
b2685f0c	237	}
	238
	239
	240	/* These two are static helpers for next::method and friends,
	241	and re-implement a bunch of the code from pp_caller() in
	242	a more efficient manner for this particular usage.
	243	*/
	244
	245	static I32
	246	__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
	247	I32 i;
	248	for (i = startingblock; i >= 0; i--) {
	249	if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
	250	}
	251	return i;
	252	}
	253
1e9bd118	254	MODULE = mro PACKAGE = mro PREFIX = mro_
b2685f0c	255
b2685f0c	256	void
1e9bd118	257	mro_get_linear_isa(...)
	258	PROTOTYPE: $;$
	259	PREINIT:
	260	AV* RETVAL;
	261	HV* class_stash;
	262	SV* classname;
	263	PPCODE:
	264	if(items < 1 \|\| items > 2)
	265	croak_xs_usage(cv, "classname [, type ]");
	266
	267	classname = ST(0);
	268	class_stash = gv_stashsv(classname, 0);
	269
	270	if(!class_stash) {
	271	/* No stash exists yet, give them just the classname */
	272	AV* isalin = newAV();
	273	av_push(isalin, newSVsv(classname));
	274	ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
	275	XSRETURN(1);
	276	}
	277	else if(items > 1) {
	278	const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
	279	if (!algo)
	280	Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
	281	RETVAL = algo->resolve(aTHX_ class_stash, 0);
	282	}
	283	else {
	284	RETVAL = mro_get_linear_isa(class_stash);
	285	}
	286	ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
	287	sv_2mortal(ST(0));
	288	XSRETURN(1);
	289
	290	void
	291	mro_set_mro(...)
	292	PROTOTYPE: $$
	293	PREINIT:
	294	SV* classname;
1e9bd118	295	HV* class_stash;
	296	struct mro_meta* meta;
	297	PPCODE:
	298	if (items != 2)
	299	croak_xs_usage(cv, "classname, type");
	300
	301	classname = ST(0);
	302	class_stash = gv_stashsv(classname, GV_ADD);
	303	if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
	304	meta = HvMROMETA(class_stash);
	305
	306	Perl_mro_set_mro(aTHX_ meta, ST(1));
	307
	308	XSRETURN_EMPTY;
	309
	310	void
	311	mro_get_mro(...)
	312	PROTOTYPE: $
	313	PREINIT:
	314	SV* classname;
	315	HV* class_stash;
	316	PPCODE:
	317	if (items != 1)
	318	croak_xs_usage(cv, "classname");
	319
	320	classname = ST(0);
	321	class_stash = gv_stashsv(classname, 0);
	322
fbb5a95c	323	if (class_stash) {
	324	const struct mro_alg *const meta = HvMROMETA(class_stash)->mro_which;
	325	ST(0) = newSVpvn_flags(meta->name, meta->length,
	326	SVs_TEMP
	327	\| ((meta->kflags & HVhek_UTF8) ? SVf_UTF8 : 0));
	328	} else {
	329	ST(0) = newSVpvn_flags("dfs", 3, SVs_TEMP);
	330	}
1e9bd118	331	XSRETURN(1);
	332
	333	void
	334	mro_get_isarev(...)
	335	PROTOTYPE: $
	336	PREINIT:
	337	SV* classname;
	338	HE* he;
	339	HV* isarev;
	340	AV* ret_array;
	341	PPCODE:
	342	if (items != 1)
	343	croak_xs_usage(cv, "classname");
	344
	345	classname = ST(0);
	346
	347	he = hv_fetch_ent(PL_isarev, classname, 0, 0);
	348	isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
	349
	350	ret_array = newAV();
	351	if(isarev) {
	352	HE* iter;
	353	hv_iterinit(isarev);
	354	while((iter = hv_iternext(isarev)))
	355	av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
	356	}
	357	mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
	358
	359	PUTBACK;
	360
	361	void
	362	mro_is_universal(...)
	363	PROTOTYPE: $
	364	PREINIT:
	365	SV* classname;
	366	HV* isarev;
	367	char* classname_pv;
	368	STRLEN classname_len;
	369	HE* he;
	370	PPCODE:
	371	if (items != 1)
	372	croak_xs_usage(cv, "classname");
	373
	374	classname = ST(0);
	375
	376	classname_pv = SvPV(classname,classname_len);
	377
	378	he = hv_fetch_ent(PL_isarev, classname, 0, 0);
	379	isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
	380
	381	if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
	382	\|\| (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
	383	XSRETURN_YES;
	384	else
	385	XSRETURN_NO;
	386
	387
	388	void
	389	mro_invalidate_method_caches(...)
	390	PROTOTYPE:
	391	PPCODE:
	392	if (items != 0)
	393	croak_xs_usage(cv, "");
	394
395	PL_sub_generation++;
396
397	XSRETURN_EMPTY;
398
399	void
400	mro_get_pkg_gen(...)
401	PROTOTYPE: $
402	PREINIT:
403	SV* classname;
404	HV* class_stash;
405	PPCODE:
406	if(items != 1)
407	croak_xs_usage(cv, "classname");
408
409	classname = ST(0);
410
411	class_stash = gv_stashsv(classname, 0);
412
413	mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
414
415	PUTBACK;
416
417	void
418	mro__nextcan(...)
b2685f0c	419	PREINIT:
	420	SV* self = ST(0);
	421	const I32 throw_nomethod = SvIVX(ST(1));
	422	register I32 cxix = cxstack_ix;
	423	register const PERL_CONTEXT *ccstack = cxstack;
	424	const PERL_SI *top_si = PL_curstackinfo;
	425	HV* selfstash;
	426	SV *stashname;
	427	const char *fq_subname;
	428	const char *subname;
	429	STRLEN stashname_len;
	430	STRLEN subname_len;
	431	SV* sv;
	432	GV** gvp;
	433	AV* linear_av;
	434	SV** linear_svp;
	435	const char *hvname;
	436	I32 entries;
	437	struct mro_meta* selfmeta;
	438	HV* nmcache;
	439	I32 i;
	440	PPCODE:
	441	PERL_UNUSED_ARG(cv);
	442
	443	if(sv_isobject(self))
	444	selfstash = SvSTASH(SvRV(self));
	445	else
	446	selfstash = gv_stashsv(self, GV_ADD);
	447
	448	assert(selfstash);
	449
	450	hvname = HvNAME_get(selfstash);
	451	if (!hvname)
	452	Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
	453
	454	/* This block finds the contextually-enclosing fully-qualified subname,
	455	much like looking at (caller($i))[3] until you find a real sub that
	456	isn't ANON, etc (also skips over pureperl next::method, etc) */
	457	for(i = 0; i < 2; i++) {
	458	cxix = __dopoptosub_at(ccstack, cxix);
	459	for (;;) {
	460	GV* cvgv;
	461	STRLEN fq_subname_len;
	462
	463	/* we may be in a higher stacklevel, so dig down deeper */
	464	while (cxix < 0) {
	465	if(top_si->si_type == PERLSI_MAIN)
	466	Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
	467	top_si = top_si->si_prev;
	468	ccstack = top_si->si_cxstack;
	469	cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
	470	}
	471
	472	if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
	473	\|\| (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
	474	cxix = __dopoptosub_at(ccstack, cxix - 1);
	475	continue;
	476	}
	477
	478	{
	479	const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
	480	if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
	481	if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
	482	cxix = dbcxix;
483	continue;
484	}
485	}
486	}
487
488	cvgv = CvGV(ccstack[cxix].blk_sub.cv);
489
490	if(!isGV(cvgv)) {
491	cxix = __dopoptosub_at(ccstack, cxix - 1);
492	continue;
493	}
494
495	/* we found a real sub here */
496	sv = sv_2mortal(newSV(0));
497
498	gv_efullname3(sv, cvgv, NULL);
499
500	fq_subname = SvPVX(sv);
501	fq_subname_len = SvCUR(sv);
502
503	subname = strrchr(fq_subname, ':');
504	if(!subname)
505	Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
506
507	subname++;
508	subname_len = fq_subname_len - (subname - fq_subname);
509	if(subname_len == 8 && strEQ(subname, "__ANON__")) {
510	cxix = __dopoptosub_at(ccstack, cxix - 1);
511	continue;
512	}
513	break;
514	}
515	cxix--;
516	}
517
518	/* If we made it to here, we found our context */
519
520	/* Initialize the next::method cache for this stash
521	if necessary */
522	selfmeta = HvMROMETA(selfstash);
523	if(!(nmcache = selfmeta->mro_nextmethod)) {
524	nmcache = selfmeta->mro_nextmethod = newHV();
525	}
526	else { /* Use the cached coderef if it exists */
527	HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
528	if (cache_entry) {
529	SV* const val = HeVAL(cache_entry);
530	if(val == &PL_sv_undef) {
531	if(throw_nomethod)
532	Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
533	XSRETURN_EMPTY;
534	}
535	mXPUSHs(newRV_inc(val));
536	XSRETURN(1);
537	}
538	}
539
540	/* beyond here is just for cache misses, so perf isn't as critical */
541
542	stashname_len = subname - fq_subname - 2;
543	stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
544
545	/* has ourselves at the top of the list */
546	linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);
547
548	linear_svp = AvARRAY(linear_av);
549	entries = AvFILLp(linear_av) + 1;
550
551	/* Walk down our MRO, skipping everything up
552	to the contextually enclosing class */
553	while (entries--) {
554	SV * const linear_sv = *linear_svp++;
555	assert(linear_sv);
556	if(sv_eq(linear_sv, stashname))
557	break;
558	}
559
560	/* Now search the remainder of the MRO for the
561	same method name as the contextually enclosing
562	method */
563	if(entries > 0) {
564	while (entries--) {
565	SV * const linear_sv = *linear_svp++;
566	HV* curstash;
567	GV* candidate;
568	CV* cand_cv;
569
570	assert(linear_sv);
571	curstash = gv_stashsv(linear_sv, FALSE);
572
573	if (!curstash) {
574	if (ckWARN(WARN_SYNTAX))
575	Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
576	(void*)linear_sv, hvname);
577	continue;
578	}
579
580	assert(curstash);
581
582	gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
583	if (!gvp) continue;
584
585	candidate = *gvp;
586	assert(candidate);
587
588	if (SvTYPE(candidate) != SVt_PVGV)
589	gv_init(candidate, curstash, subname, subname_len, TRUE);
590
591	/* Notably, we only look for real entries, not method cache
592	entries, because in C3 the method cache of a parent is not
593	valid for the child */
594	if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
595	SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
596	(void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0);
597	mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
598	XSRETURN(1);
599	}
600	}
601	}
602
603	(void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
604	if(throw_nomethod)
605	Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
606	XSRETURN_EMPTY;
607
608	BOOT:
609	Perl_mro_register(aTHX_ &c3_alg);