[gitmo/Class-C3-XS.git] / XS.xs


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

/* Most of this code is backported from the bleadperl patch's
   mro.c, and then modified to work with Class::C3's
   internals.
*/

AV*
__mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level)
{
    AV* retval;
    GV** gvp;
    GV* gv;
    AV* isa;
    const char* stashname;
    STRLEN stashname_len;
    I32 made_mortal_cache = 0;

    assert(stash);
    assert(HvAUX(stash));

    stashname = HvNAME(stash);
    stashname_len = strlen(stashname);
    if (!stashname)
      Perl_croak(aTHX_
                 "Can't linearize anonymous symbol table");

    if (level > 100)
        Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
              stashname);

    if(!cache) {
        cache = (HV*)sv_2mortal((SV*)newHV());
        made_mortal_cache = 1;
    }
    else {
        SV** cache_entry = hv_fetch(cache, stashname, stashname_len, 0);
        if(cache_entry)
            return (AV*)SvREFCNT_inc(*cache_entry);
    }

    /* not in cache, make a new one */

    gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
    isa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;

    if(isa && AvFILLp(isa) >= 0) {
        SV** seqs_ptr;
        I32 seqs_items;
        HV* const tails = (HV*)sv_2mortal((SV*)newHV());
        AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
        I32* heads;

        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) {
                AV* const isa_lin = newAV();
                av_push(isa_lin, newSVsv(isa_item));
                av_push(seqs, (SV*)isa_lin);
            }
            else {
                AV* const isa_lin = __mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1); /* recursion */
                av_push(seqs, (SV*)isa_lin);
            }
        }
        av_push(seqs, SvREFCNT_inc((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) */

        Newz(0xdead, 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 = (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++;
                    HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
                    if(!he) {
                        hv_store_ent(tails, seqitem, newSViv(1), 0);
                    }
                    else {
                        SV* const val = HeVAL(he);
                        sv_inc(val);
                    }
                }
            }
        }

        /* Initialize retval to build the return value in */
        retval = newAV();
        av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */

        while(1) {
            SV* cand = NULL;
            SV* winner = NULL;
            int s;

            SV** const avptr = AvARRAY(seqs);
            for(s = 0; s <= AvFILLp(seqs); s++) {
                SV** svp;
                AV * const seq = (AV*)(avptr[s]);
                SV* seqhead;
                if(!seq) continue;
                svp = av_fetch(seq, heads[s], 0);
                seqhead = *svp;
                if(!winner) {
                    HE* tail_entry;
                    SV* val;
                    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);
                }
                if(!sv_cmp(seqhead, winner)) {
                    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(!cand) {
                Safefree(heads);
                break;
            }
            if(!winner) {
                SvREFCNT_dec(retval);
                Safefree(heads);
                Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
                    "merging failed on parent '%s'", stashname, SvPV_nolen(cand));
            }
        }
    }
    else { /* @ISA does not exist, or was empty */
        retval = newAV();
        av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
    }

    SvREADONLY_on(retval);

    if(!made_mortal_cache) {
        SvREFCNT_inc(retval);
        hv_store(cache, stashname, stashname_len, (SV*)retval, 0);
    }

    return retval;
}

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

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;
    GV* cvgv;
    SV *stashname;
    const char *fq_subname;
    const char *subname;
    STRLEN fq_subname_len;
    STRLEN stashname_len;
    STRLEN subname_len;
    SV* sv;
    GV** gvp;
    AV* linear_av;
    SV** linear_svp;
    SV* linear_sv;
    HV* cstash;
    GV* candidate = NULL;
    CV* cand_cv = NULL;
    const char *hvname;
    I32 items;
    HV* nmcache;
    HE* cache_entry;
    SV* cachekey;

    if(sv_isobject(self))
        selfstash = SvSTASH(SvRV(self));
    else
        selfstash = gv_stashsv(self, 0);

    assert(selfstash);

    hvname = HvNAME(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 (;;) {
        /* 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 */

    /* cachekey = "objpkg|context::method::name" */
    cachekey = sv_2mortal(newSVpv(hvname, 0));
    sv_catpvn(cachekey, "|", 1);
    sv_catsv(cachekey, sv);

    nmcache = get_hv("next::METHOD_CACHE", 1);
    if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
        SV* 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 &PL_sv_undef;
        }
        return SvREFCNT_inc(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_linear_isa_c3(aTHX_ selfstash, NULL, 0);

    linear_svp = AvARRAY(linear_av);
    items = AvFILLp(linear_av) + 1;

    while (items--) {
        linear_sv = *linear_svp++;
        assert(linear_sv);
        if(sv_eq(linear_sv, stashname))
            break;
    }

    if(items > 0) {
        SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
        HV* cc3_mro = get_hv("Class::C3::MRO", 0);

        while (items--) {
            linear_sv = *linear_svp++;
            assert(linear_sv);

            if(cc3_mro) {
                HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
                if(he_cc3_mro_class) {
                    SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
                    if(SvROK(cc3_mro_class_sv)) {
                        HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
                        SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
                        if(svp_cc3_mro_class_methods) {
                            SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
                            if(SvROK(cc3_mro_class_methods_sv)) {
                                HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
                                if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
                                    continue;
                            }
                        }
                    }
                }
            }

            cstash = gv_stashsv(linear_sv, FALSE);

            if (!cstash) {
                if (ckWARN(WARN_MISC))
                    Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
                        (void*)linear_sv, hvname);
                continue;
            }

            assert(cstash);

            gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
            if (!gvp) continue;

            candidate = *gvp;
            assert(candidate);

            if (SvTYPE(candidate) != SVt_PVGV)
                gv_init(candidate, cstash, subname, subname_len, TRUE);
            if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
                SvREFCNT_dec(linear_av);
                SvREFCNT_inc((SV*)cand_cv);
                hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0);
                return (SV*)cand_cv;
            }
        }
    }

    SvREFCNT_dec(linear_av);
    hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0);
    if(throw_nomethod)
        Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
    return &PL_sv_undef;
}

XS(XS_Class_C3_XS_calculateMRO);
XS(XS_Class_C3_XS_calculateMRO)
{
#ifdef dVAR
    dVAR; dXSARGS;
#else
    dXSARGS;
#endif

    SV* classname;
    HV* class_stash;
    HV* cache = NULL;
    AV* res;
    I32 res_items;
    I32 ret_items;
    SV** res_ptr;

    if(items < 1 || items > 2)
        croak("Usage: calculateMRO(classname[, cache])");

    classname = ST(0);
    if(items == 2) cache = (HV*)SvRV(ST(1));

    class_stash = gv_stashsv(classname, 0);
    if(!class_stash)
        Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));

    res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);

    res_items = ret_items = AvFILLp(res) + 1;
    res_ptr = AvARRAY(res);

    SP -= items;

    while(res_items--) {
        SV* res_item = *res_ptr++;
        XPUSHs(sv_2mortal(newSVsv(res_item)));
    }
    SvREFCNT_dec(res);

    PUTBACK;

    return;
}

XS(XS_Class_C3_XS_plsubgen);
XS(XS_Class_C3_XS_plsubgen)
{
    #ifdef dVAR
        dVAR; dXSARGS;
    #else
        dXSARGS;
    #endif

    SP -= items;
    XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
    PUTBACK;
    return;
}

XS(XS_Class_C3_XS_calc_mdt);
XS(XS_Class_C3_XS_calc_mdt)
{
#ifdef dVAR
    dVAR; dXSARGS;
#else
    dXSARGS;
#endif

    SV* classname;
    HV* cache;
    HV* class_stash;
    AV* class_mro;
    HV* our_c3mro; /* $Class::C3::MRO{classname} */
    SV* has_ovf = NULL;
    HV* methods;
    I32 mroitems;

    /* temps */
    HV* hv;
    HE* he;
    SV** svp;

    if(items < 1 || items > 2)
        croak("Usage: calculate_method_dispatch_table(classname[, cache])");

    classname = ST(0);
    class_stash = gv_stashsv(classname, 0);
    if(!class_stash)
        Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));

    if(items == 2) cache = (HV*)SvRV(ST(1));

    class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);

    our_c3mro = newHV();
    hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0);

    hv = get_hv("Class::C3::MRO", 1);
    hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0);

    methods = newHV();

    /* skip first entry */
    mroitems = AvFILLp(class_mro);
    svp = AvARRAY(class_mro) + 1;
    while(mroitems--) {
        SV* mro_class = *svp++;
        HV* mro_stash = gv_stashsv(mro_class, 0);

        if(!mro_stash) continue;

        if(!has_ovf) {
            SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
            if(ovfp) has_ovf = *ovfp;
        }

        hv_iterinit(mro_stash);
        while(he = hv_iternext(mro_stash)) {
            CV* code;
            SV* mskey;
            SV* msval;
            HE* ourent;
            HV* meth_hash;
            SV* orig;

            mskey = hv_iterkeysv(he);
            if(hv_exists_ent(methods, mskey, 0)) continue;

            msval = hv_iterval(mro_stash, he);
            if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
                continue;

            if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
                SV* val = HeVAL(ourent);
                if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
                    continue;
            }

            meth_hash = newHV();
            orig = newSVsv(mro_class);
            sv_catpvn(orig, "::", 2);
            sv_catsv(orig, mskey);
            hv_store(meth_hash, "orig", 4, orig, 0);
            hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0);
            hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0);
        }
    }

    hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0);
    if(has_ovf) hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0);
    XSRETURN_EMPTY;
}

XS(XS_next_can);
XS(XS_next_can)
{
#ifdef dVAR
    dVAR; dXSARGS;
#else
    dXSARGS;
#endif

    SV* self = ST(0);
    SV* methcv = __nextcan(aTHX_ self, 0);

    PERL_UNUSED_VAR(items);

    if(methcv == &PL_sv_undef) {
        ST(0) = &PL_sv_undef;
    }
    else {
        ST(0) = sv_2mortal(newRV_inc(methcv));
    }

    XSRETURN(1);
}

XS(XS_next_method);
XS(XS_next_method)
{
    dMARK;
    dAX;
    SV* self = ST(0);
    SV* methcv = __nextcan(aTHX_ self, 1);

    PL_markstack_ptr++;
    call_sv(methcv, GIMME_V);
}

XS(XS_maybe_next_method);
XS(XS_maybe_next_method)
{
    dMARK;
    dAX;
    SV* self = ST(0);
    SV* methcv = __nextcan(aTHX_ self, 0);

    if(methcv == &PL_sv_undef) {
        ST(0) = &PL_sv_undef;
        XSRETURN(1);
    }

    PL_markstack_ptr++;
    call_sv(methcv, GIMME_V);
}

MODULE = Class::C3::XS	PACKAGE = Class::C3::XS

BOOT:
    newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
    newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
    newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
    newXS("next::can", XS_next_can, __FILE__);
    newXS("next::method", XS_next_method, __FILE__);
    newXS("maybe::next::method", XS_maybe_next_method, __FILE__);
Commit	Line	Data
8995e827	1
	2	#include "EXTERN.h"
	3	#include "perl.h"
	4	#include "XSUB.h"
8995e827	5
29e61e10	6	/* Most of this code is backported from the bleadperl patch's
b23e9cb9	7	mro.c, and then modified to work with Class::C3's
	8	internals.
	9	*/
8995e827	10
b23e9cb9	11	AV*
	12	__mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level)
	13	{
	14	AV* retval;
	15	GV** gvp;
	16	GV* gv;
	17	AV* isa;
	18	const char* stashname;
	19	STRLEN stashname_len;
bb82f0c1	20	I32 made_mortal_cache = 0;
8995e827	21
b23e9cb9	22	assert(stash);
bb82f0c1	23	assert(HvAUX(stash));
8995e827	24
b23e9cb9	25	stashname = HvNAME(stash);
	26	stashname_len = strlen(stashname);
	27	if (!stashname)
	28	Perl_croak(aTHX_
	29	"Can't linearize anonymous symbol table");
8995e827	30
b23e9cb9	31	if (level > 100)
	32	Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
	33	stashname);
8995e827	34
b23e9cb9	35	if(!cache) {
f0294f1b	36	cache = (HV)sv_2mortal((SV)newHV());
bb82f0c1	37	made_mortal_cache = 1;
b23e9cb9	38	}
b23e9cb9	39	else {
6bf46d18	40	SV** cache_entry = hv_fetch(cache, stashname, stashname_len, 0);
	41	if(cache_entry)
	42	return (AV)SvREFCNT_inc(cache_entry);
b23e9cb9	43	}
	44
	45	/* not in cache, make a new one */
	46
b23e9cb9	47	gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
	48	isa = (gvp && (gv = gvp) && gv != (GV)&PL_sv_undef) ? GvAV(gv) : NULL;
	49
	50	if(isa && AvFILLp(isa) >= 0) {
	51	SV** seqs_ptr;
	52	I32 seqs_items;
bb82f0c1	53	HV* const tails = (HV)sv_2mortal((SV)newHV());
	54	AV* const seqs = (AV)sv_2mortal((SV)newAV());
	55	I32* heads;
	56
b23e9cb9	57	I32 items = AvFILLp(isa) + 1;
	58	SV** isa_ptr = AvARRAY(isa);
	59	while(items--) {
bb82f0c1	60	SV* const isa_item = *isa_ptr++;
bb82f0c1	61	HV* const isa_item_stash = gv_stashsv(isa_item, 0);
b23e9cb9	62	if(!isa_item_stash) {
bb82f0c1	63	AV* const isa_lin = newAV();
b23e9cb9	64	av_push(isa_lin, newSVsv(isa_item));
bb82f0c1	65	av_push(seqs, (SV*)isa_lin);
b23e9cb9	66	}
b23e9cb9	67	else {
bb82f0c1	68	AV* const isa_lin = __mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1); /* recursion */
bb82f0c1	69	av_push(seqs, (SV*)isa_lin);
b23e9cb9	70	}
b23e9cb9	71	}
bb82f0c1	72	av_push(seqs, SvREFCNT_inc((SV*)isa));
	73
	74	/* This builds "heads", which as an array of integer array
	75	indices, one per seq, which point at the virtual "head"
	76	of the seq (initially zero) */
	77
	78	Newz(0xdead, heads, AvFILLp(seqs)+1, I32);
b23e9cb9	79
bb82f0c1	80	/* This builds %tails, which has one key for every class
	81	mentioned in the tail of any sequence in @seqs (tail meaning
	82	everything after the first class, the "head"). The value
	83	is how many times this key appears in the tails of @seqs.
	84	*/
b23e9cb9	85	seqs_ptr = AvARRAY(seqs);
	86	seqs_items = AvFILLp(seqs) + 1;
	87	while(seqs_items--) {
bb82f0c1	88	AV* const seq = (AV)seqs_ptr++;
b23e9cb9	89	I32 seq_items = AvFILLp(seq);
	90	if(seq_items > 0) {
	91	SV** seq_ptr = AvARRAY(seq) + 1;
	92	while(seq_items--) {
bb82f0c1	93	SV* const seqitem = *seq_ptr++;
bb82f0c1	94	HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
b23e9cb9	95	if(!he) {
	96	hv_store_ent(tails, seqitem, newSViv(1), 0);
	97	}
	98	else {
bb82f0c1	99	SV* const val = HeVAL(he);
b23e9cb9	100	sv_inc(val);
	101	}
	102	}
	103	}
	104	}
	105
bb82f0c1	106	/* Initialize retval to build the return value in */
	107	retval = newAV();
	108	av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
	109
b23e9cb9	110	while(1) {
b23e9cb9	111	SV* cand = NULL;
b23e9cb9	112	SV* winner = NULL;
bb82f0c1	113	int s;
	114
	115	SV** const avptr = AvARRAY(seqs);
	116	for(s = 0; s <= AvFILLp(seqs); s++) {
b23e9cb9	117	SV** svp;
bb82f0c1	118	AV * const seq = (AV*)(avptr[s]);
	119	SV* seqhead;
	120	if(!seq) continue;
	121	svp = av_fetch(seq, heads[s], 0);
b23e9cb9	122	seqhead = *svp;
b23e9cb9	123	if(!winner) {
bb82f0c1	124	HE* tail_entry;
bb82f0c1	125	SV* val;
b23e9cb9	126	cand = seqhead;
	127	if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
	128	&& (val = HeVAL(tail_entry))
	129	&& (SvIVx(val) > 0))
	130	continue;
	131	winner = newSVsv(cand);
	132	av_push(retval, winner);
	133	}
	134	if(!sv_cmp(seqhead, winner)) {
bb82f0c1	135	const int new_head = ++heads[s];
	136	if(new_head > AvFILLp(seq)) {
	137	SvREFCNT_dec(avptr[s]);
	138	avptr[s] = NULL;
	139	}
	140	else {
	141	HE* tail_entry;
	142	SV* val;
	143	/* Because we know this new seqhead used to be
	144	a tail, we can assume it is in tails and has
	145	a positive value, which we need to dec */
	146	svp = av_fetch(seq, new_head, 0);
	147	seqhead = *svp;
	148	tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
	149	val = HeVAL(tail_entry);
	150	sv_dec(val);
	151	}
b23e9cb9	152	}
b23e9cb9	153	}
bb82f0c1	154	if(!cand) {
	155	Safefree(heads);
	156	break;
	157	}
62eb9d08	158	if(!winner) {
62eb9d08	159	SvREFCNT_dec(retval);
bb82f0c1	160	Safefree(heads);
b23e9cb9	161	Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
b23e9cb9	162	"merging failed on parent '%s'", stashname, SvPV_nolen(cand));
62eb9d08	163	}
b23e9cb9	164	}
b23e9cb9	165	}
bb82f0c1	166	else { /* @ISA does not exist, or was empty */
	167	retval = newAV();
	168	av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
	169	}
b23e9cb9	170
b23e9cb9	171	SvREADONLY_on(retval);
bb82f0c1	172
	173	if(!made_mortal_cache) {
	174	SvREFCNT_inc(retval);
	175	hv_store(cache, stashname, stashname_len, (SV*)retval, 0);
	176	}
	177
	178	return retval;
b23e9cb9	179	}
	180
	181	STATIC I32
	182	__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
	183	I32 i;
	184	for (i = startingblock; i >= 0; i--) {
	185	if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
	186	}
	187	return i;
	188	}
	189
	190	STATIC SV*
	191	__nextcan(pTHX_ SV* self, I32 throw_nomethod)
	192	{
	193	register I32 cxix;
	194	register const PERL_CONTEXT *ccstack = cxstack;
	195	const PERL_SI *top_si = PL_curstackinfo;
	196	HV* selfstash;
	197	GV* cvgv;
	198	SV *stashname;
	199	const char *fq_subname;
	200	const char *subname;
	201	STRLEN fq_subname_len;
	202	STRLEN stashname_len;
	203	STRLEN subname_len;
	204	SV* sv;
	205	GV** gvp;
	206	AV* linear_av;
	207	SV** linear_svp;
	208	SV* linear_sv;
	209	HV* cstash;
	210	GV* candidate = NULL;
	211	CV* cand_cv = NULL;
	212	const char *hvname;
	213	I32 items;
6c88cc6a	214	HV* nmcache;
b23e9cb9	215	HE* cache_entry;
22c6f594	216	SV* cachekey;
b23e9cb9	217
	218	if(sv_isobject(self))
	219	selfstash = SvSTASH(SvRV(self));
	220	else
	221	selfstash = gv_stashsv(self, 0);
	222
	223	assert(selfstash);
	224
	225	hvname = HvNAME(selfstash);
	226	if (!hvname)
625e16df	227	Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
b23e9cb9	228
	229	cxix = __dopoptosub_at(cxstack, cxstack_ix);
	230
	231	/* This block finds the contextually-enclosing fully-qualified subname,
	232	much like looking at (caller($i))[3] until you find a real sub that
	233	isn't ANON, etc */
	234	for (;;) {
	235	/* we may be in a higher stacklevel, so dig down deeper */
	236	while (cxix < 0) {
	237	if(top_si->si_type == PERLSI_MAIN)
625e16df	238	Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
b23e9cb9	239	top_si = top_si->si_prev;
	240	ccstack = top_si->si_cxstack;
	241	cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
	242	}
	243
	244	if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
	245	\|\| (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
	246	cxix = __dopoptosub_at(ccstack, cxix - 1);
	247	continue;
	248	}
	249
	250	{
	251	const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
	252	if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
	253	if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
	254	cxix = dbcxix;
	255	continue;
	256	}
	257	}
	258	}
	259
	260	cvgv = CvGV(ccstack[cxix].blk_sub.cv);
	261
	262	if(!isGV(cvgv)) {
	263	cxix = __dopoptosub_at(ccstack, cxix - 1);
	264	continue;
	265	}
	266
	267	/* we found a real sub here */
	268	sv = sv_2mortal(newSV(0));
	269
	270	gv_efullname3(sv, cvgv, NULL);
	271
	272	fq_subname = SvPVX(sv);
	273	fq_subname_len = SvCUR(sv);
	274
	275	subname = strrchr(fq_subname, ':');
	276	if(!subname)
625e16df	277	Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
b23e9cb9	278
	279	subname++;
	280	subname_len = fq_subname_len - (subname - fq_subname);
	281	if(subname_len == 8 && strEQ(subname, "__ANON__")) {
	282	cxix = __dopoptosub_at(ccstack, cxix - 1);
	283	continue;
	284	}
	285	break;
	286	}
	287
	288	/* If we made it to here, we found our context */
	289
22c6f594	290	/* cachekey = "objpkg\|context::method::name" */
	291	cachekey = sv_2mortal(newSVpv(hvname, 0));
	292	sv_catpvn(cachekey, "\|", 1);
	293	sv_catsv(cachekey, sv);
b23e9cb9	294
6c88cc6a	295	nmcache = get_hv("next::METHOD_CACHE", 1);
22c6f594	296	if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
b23e9cb9	297	SV* val = HeVAL(cache_entry);
	298	if(val == &PL_sv_undef) {
	299	if(throw_nomethod)
625e16df	300	Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
b23e9cb9	301	return &PL_sv_undef;
	302	}
	303	return SvREFCNT_inc(val);
	304	}
b23e9cb9	305
	306	/* beyond here is just for cache misses, so perf isn't as critical */
	307
	308	stashname_len = subname - fq_subname - 2;
	309	stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
	310
62eb9d08	311	linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
b23e9cb9	312
	313	linear_svp = AvARRAY(linear_av);
	314	items = AvFILLp(linear_av) + 1;
	315
	316	while (items--) {
	317	linear_sv = *linear_svp++;
	318	assert(linear_sv);
	319	if(sv_eq(linear_sv, stashname))
	320	break;
	321	}
	322
	323	if(items > 0) {
29e61e10	324	SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
29e61e10	325	HV* cc3_mro = get_hv("Class::C3::MRO", 0);
29e61e10	326
b23e9cb9	327	while (items--) {
	328	linear_sv = *linear_svp++;
	329	assert(linear_sv);
29e61e10	330
	331	if(cc3_mro) {
	332	HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
	333	if(he_cc3_mro_class) {
3499e05c	334	SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
	335	if(SvROK(cc3_mro_class_sv)) {
	336	HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
	337	SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
	338	if(svp_cc3_mro_class_methods) {
	339	SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
	340	if(SvROK(cc3_mro_class_methods_sv)) {
	341	HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
	342	if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
	343	continue;
	344	}
	345	}
29e61e10	346	}
	347	}
	348	}
	349
b23e9cb9	350	cstash = gv_stashsv(linear_sv, FALSE);
	351
	352	if (!cstash) {
	353	if (ckWARN(WARN_MISC))
	354	Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
	355	(void*)linear_sv, hvname);
	356	continue;
	357	}
	358
	359	assert(cstash);
	360
b23e9cb9	361	gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
	362	if (!gvp) continue;
	363
	364	candidate = *gvp;
	365	assert(candidate);
	366
	367	if (SvTYPE(candidate) != SVt_PVGV)
	368	gv_init(candidate, cstash, subname, subname_len, TRUE);
	369	if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
62eb9d08	370	SvREFCNT_dec(linear_av);
b23e9cb9	371	SvREFCNT_inc((SV*)cand_cv);
22c6f594	372	hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0);
b23e9cb9	373	return (SV*)cand_cv;
	374	}
	375	}
	376	}
	377
62eb9d08	378	SvREFCNT_dec(linear_av);
22c6f594	379	hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0);
b23e9cb9	380	if(throw_nomethod)
625e16df	381	Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
b23e9cb9	382	return &PL_sv_undef;
	383	}
	384
	385	XS(XS_Class_C3_XS_calculateMRO);
	386	XS(XS_Class_C3_XS_calculateMRO)
	387	{
	388	#ifdef dVAR
	389	dVAR; dXSARGS;
	390	#else
	391	dXSARGS;
	392	#endif
	393
	394	SV* classname;
	395	HV* class_stash;
	396	HV* cache = NULL;
	397	AV* res;
	398	I32 res_items;
	399	I32 ret_items;
	400	SV** res_ptr;
	401
	402	if(items < 1 \|\| items > 2)
	403	croak("Usage: calculateMRO(classname[, cache])");
	404
	405	classname = ST(0);
f0294f1b	406	if(items == 2) cache = (HV*)SvRV(ST(1));
b23e9cb9	407
b23e9cb9	408	class_stash = gv_stashsv(classname, 0);
625e16df	409	if(!class_stash)
625e16df	410	Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
b23e9cb9	411
62eb9d08	412	res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
b23e9cb9	413
b23e9cb9	414	res_items = ret_items = AvFILLp(res) + 1;
	415	res_ptr = AvARRAY(res);
	416
	417	SP -= items;
	418
	419	while(res_items--) {
	420	SV* res_item = *res_ptr++;
62eb9d08	421	XPUSHs(sv_2mortal(newSVsv(res_item)));
b23e9cb9	422	}
62eb9d08	423	SvREFCNT_dec(res);
b23e9cb9	424
	425	PUTBACK;
	426
	427	return;
	428	}
	429
8feecaf9	430	XS(XS_Class_C3_XS_plsubgen);
	431	XS(XS_Class_C3_XS_plsubgen)
	432	{
	433	#ifdef dVAR
	434	dVAR; dXSARGS;
	435	#else
	436	dXSARGS;
	437	#endif
	438
	439	SP -= items;
	440	XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
	441	PUTBACK;
	442	return;
	443	}
	444
625e16df	445	XS(XS_Class_C3_XS_calc_mdt);
	446	XS(XS_Class_C3_XS_calc_mdt)
	447	{
	448	#ifdef dVAR
	449	dVAR; dXSARGS;
	450	#else
	451	dXSARGS;
	452	#endif
	453
	454	SV* classname;
	455	HV* cache;
	456	HV* class_stash;
	457	AV* class_mro;
	458	HV* our_c3mro; /* $Class::C3::MRO{classname} */
79782a49	459	SV* has_ovf = NULL;
625e16df	460	HV* methods;
	461	I32 mroitems;
	462
	463	/* temps */
	464	HV* hv;
	465	HE* he;
625e16df	466	SV** svp;
	467
	468	if(items < 1 \|\| items > 2)
	469	croak("Usage: calculate_method_dispatch_table(classname[, cache])");
	470
	471	classname = ST(0);
	472	class_stash = gv_stashsv(classname, 0);
	473	if(!class_stash)
	474	Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
	475
	476	if(items == 2) cache = (HV*)SvRV(ST(1));
	477
	478	class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
	479
	480	our_c3mro = newHV();
bb82f0c1	481	hv_store(our_c3mro, "MRO", 3, (SV)newRV_noinc((SV)class_mro), 0);
625e16df	482
	483	hv = get_hv("Class::C3::MRO", 1);
	484	hv_store_ent(hv, classname, (SV)newRV_noinc((SV)our_c3mro), 0);
	485
	486	methods = newHV();
	487
	488	/* skip first entry */
	489	mroitems = AvFILLp(class_mro);
	490	svp = AvARRAY(class_mro) + 1;
	491	while(mroitems--) {
	492	SV* mro_class = *svp++;
	493	HV* mro_stash = gv_stashsv(mro_class, 0);
	494
	495	if(!mro_stash) continue;
	496
79782a49	497	if(!has_ovf) {
625e16df	498	SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
625e16df	499	if(ovfp) has_ovf = *ovfp;
79782a49	500	}
625e16df	501
	502	hv_iterinit(mro_stash);
	503	while(he = hv_iternext(mro_stash)) {
	504	CV* code;
	505	SV* mskey;
79782a49	506	SV* msval;
	507	HE* ourent;
	508	HV* meth_hash;
	509	SV* orig;
625e16df	510
	511	mskey = hv_iterkeysv(he);
	512	if(hv_exists_ent(methods, mskey, 0)) continue;
79782a49	513
	514	msval = hv_iterval(mro_stash, he);
	515	if(SvTYPE(msval) != SVt_PVGV \|\| !(code = GvCVu(msval)))
	516	continue;
	517
	518	if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
	519	SV* val = HeVAL(ourent);
	520	if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
625e16df	521	continue;
	522	}
	523
79782a49	524	meth_hash = newHV();
	525	orig = newSVsv(mro_class);
	526	sv_catpvn(orig, "::", 2);
	527	sv_catsv(orig, mskey);
	528	hv_store(meth_hash, "orig", 4, orig, 0);
	529	hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0);
	530	hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0);
625e16df	531	}
	532	}
	533
	534	hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0);
79782a49	535	if(has_ovf) hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0);
625e16df	536	XSRETURN_EMPTY;
	537	}
	538
b23e9cb9	539	XS(XS_next_can);
	540	XS(XS_next_can)
	541	{
	542	#ifdef dVAR
	543	dVAR; dXSARGS;
	544	#else
	545	dXSARGS;
	546	#endif
	547
	548	SV* self = ST(0);
b36f79e1	549	SV* methcv = __nextcan(aTHX_ self, 0);
b23e9cb9	550
	551	PERL_UNUSED_VAR(items);
	552
	553	if(methcv == &PL_sv_undef) {
	554	ST(0) = &PL_sv_undef;
	555	}
	556	else {
	557	ST(0) = sv_2mortal(newRV_inc(methcv));
	558	}
	559
	560	XSRETURN(1);
	561	}
	562
	563	XS(XS_next_method);
	564	XS(XS_next_method)
	565	{
	566	dMARK;
	567	dAX;
	568	SV* self = ST(0);
b36f79e1	569	SV* methcv = __nextcan(aTHX_ self, 1);
b23e9cb9	570
	571	PL_markstack_ptr++;
	572	call_sv(methcv, GIMME_V);
	573	}
	574
	575	XS(XS_maybe_next_method);
	576	XS(XS_maybe_next_method)
	577	{
	578	dMARK;
	579	dAX;
	580	SV* self = ST(0);
b36f79e1	581	SV* methcv = __nextcan(aTHX_ self, 0);
b23e9cb9	582
	583	if(methcv == &PL_sv_undef) {
	584	ST(0) = &PL_sv_undef;
	585	XSRETURN(1);
	586	}
	587
	588	PL_markstack_ptr++;
	589	call_sv(methcv, GIMME_V);
	590	}
	591
	592	MODULE = Class::C3::XS PACKAGE = Class::C3::XS
	593
	594	BOOT:
	595	newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
8feecaf9	596	newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
625e16df	597	newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
b23e9cb9	598	newXS("next::can", XS_next_can, __FILE__);
	599	newXS("next::method", XS_next_method, __FILE__);
	600	newXS("maybe::next::method", XS_maybe_next_method, __FILE__);
625e16df	601