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


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

/* *********** ppport stuff */

#ifndef PERL_UNUSED_VAR
#  define PERL_UNUSED_VAR(x) ((void)x)
#endif

#if defined(PERL_GCC_PEDANTIC)
#  ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
#    define PERL_GCC_BRACE_GROUPS_FORBIDDEN
#  endif
#endif

#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
#  ifndef PERL_USE_GCC_BRACE_GROUPS
#    define PERL_USE_GCC_BRACE_GROUPS
#  endif
#endif

#ifndef SvREFCNT_inc
#  ifdef PERL_USE_GCC_BRACE_GROUPS
#    define SvREFCNT_inc(sv)		\
      ({				\
          SV * const _sv = (SV*)(sv);	\
          if (_sv)			\
               (SvREFCNT(_sv))++;	\
          _sv;				\
      })
#  else
#    define SvREFCNT_inc(sv)	\
          ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL)
#  endif
#endif

#ifndef dAX
#  define dAX                            I32 ax = MARK - PL_stack_base + 1
#endif

#ifndef dVAR
#  define dVAR                           dNOOP
#endif

#ifndef packWARN
#  define packWARN(a)                    (a)
#endif

/* *********** end ppport.h stuff */

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

    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;

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

        /* 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 = (AV*)(avptr[s]);
                SV* seqhead;
                if(!seq) continue; /* skip empty seqs */
                svp = av_fetch(seq, heads[s], 0);
                seqhead = *svp; /* seqhead = head of this seq */
                if(!winner) {
                    HE* tail_entry;
                    SV* val;
                    /* if we haven't found a winner for this round yet,
                       and this seqhead is not in tails (or the count
                       for it in tails has dropped to zero), then this
                       seqhead is our new winner, and is added to the
                       final MRO immediately */
                    cand = seqhead;
                    if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
                       && (val = HeVAL(tail_entry))
                       && (SvIVX(val) > 0))
                           continue;
                    winner = newSVsv(cand);
                    av_push(retval, winner);
                    /* note however that even when we find a winner,
                       we continue looping over @seqs to do housekeeping */
                }
                if(!sv_cmp(seqhead, winner)) {
                    /* Once we have a winner (including the iteration
                       where we first found him), inc the head ptr
                       for any seq which had the winner as a head,
                       NULL out any seq which is now empty,
                       and adjust tails for consistency */

                    const int new_head = ++heads[s];
                    if(new_head > AvFILLp(seq)) {
                        SvREFCNT_dec(avptr[s]);
                        avptr[s] = NULL;
                    }
                    else {
                        HE* tail_entry;
                        SV* val;
                        /* Because we know this new seqhead used to be
                           a tail, we can assume it is in tails and has
                           a positive value, which we need to dec */
                        svp = av_fetch(seq, new_head, 0);
                        seqhead = *svp;
                        tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
                        val = HeVAL(tail_entry);
                        sv_dec(val);
                    }
                }
            }

            /* if we found no candidates, we are done building the MRO.
               !cand means no seqs have any entries left to check */
            if(!cand) {
                Safefree(heads);
                break;
            }

            /* If we had candidates, but nobody won, then the @ISA
               hierarchy is not C3-incompatible */
            if(!winner) {
                /* we have to do some cleanup before we croak */

                SvREFCNT_dec(retval);
                Safefree(heads);

                Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
                    "merging failed on parent '%s'", stashname, SvPV_nolen(cand));
            }
        }
    }
    else { /* @ISA was undefined or empty */
        /* build a retval containing only ourselves */
        retval = newAV();
        av_push(retval, newSVpvn(stashname, stashname_len));
    }

    /* we don't want anyone modifying the cache entry but us,
       and we do so by replacing it completely */
    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;
}

XS(XS_Class_C3_XS_nextcan);
XS(XS_Class_C3_XS_nextcan)
{
    dVAR; dXSARGS;

    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;
    HV* cstash;
    GV* candidate = NULL;
    CV* cand_cv = NULL;
    const char *hvname;
    I32 entries;
    HV* nmcache;
    HE* cache_entry;
    SV* cachekey;

    self = ST(0);
    throw_nomethod = SvIVX(ST(1));

    SP -= items;

    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);
    cxix = __dopoptosub_at(ccstack, cxix - 1);

    /* 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);
            XSRETURN_EMPTY;
        }
        XPUSHs(sv_2mortal(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 = sv_2mortal(newSVpvn(fq_subname, stashname_len));

    linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);

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

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

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

        while (entries--) {
            SV* const 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);
                XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
                XSRETURN(1);
            }
        }
    }

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

XS(XS_Class_C3_XS_calculateMRO);
XS(XS_Class_C3_XS_calculateMRO)
{
    dVAR; dXSARGS;

    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)
{
    dVAR; dXSARGS;

    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)
{
    dVAR; dXSARGS;

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

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