[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 = 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;
    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;
    int i;

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

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

    /* 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;
2605e591	273
e5e121c4	274	SV* self = ST(0);
e5e121c4	275	const I32 throw_nomethod = SvIVX(ST(1));
5efa8a5b	276	register I32 cxix = cxstack_ix;
b23e9cb9	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;
5efa8a5b	299	int i;
b23e9cb9	300
2605e591	301	SP -= items;
2605e591	302
b23e9cb9	303	if(sv_isobject(self))
	304	selfstash = SvSTASH(SvRV(self));
	305	else
	306	selfstash = gv_stashsv(self, 0);
	307
	308	assert(selfstash);
	309
	310	hvname = HvNAME(selfstash);
	311	if (!hvname)
625e16df	312	Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
b23e9cb9	313
b23e9cb9	314	/* This block finds the contextually-enclosing fully-qualified subname,
b23e9cb9	315	much like looking at (caller($i))[3] until you find a real sub that
5efa8a5b	316	isn't ANON, etc (also skips over pureperl next::method, etc) */
	317	for(i = 0; i < 2; i++) {
	318	cxix = __dopoptosub_at(ccstack, cxix);
	319	for (;;) {
	320	/* we may be in a higher stacklevel, so dig down deeper */
	321	while (cxix < 0) {
	322	if(top_si->si_type == PERLSI_MAIN)
	323	Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
	324	top_si = top_si->si_prev;
	325	ccstack = top_si->si_cxstack;
	326	cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
	327	}
b23e9cb9	328
5efa8a5b	329	if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
	330	\|\| (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
	331	cxix = __dopoptosub_at(ccstack, cxix - 1);
	332	continue;
	333	}
b23e9cb9	334
5efa8a5b	335	{
	336	const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
	337	if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
	338	if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
	339	cxix = dbcxix;
	340	continue;
	341	}
b23e9cb9	342	}
b23e9cb9	343	}
b23e9cb9	344
5efa8a5b	345	cvgv = CvGV(ccstack[cxix].blk_sub.cv);
b23e9cb9	346
5efa8a5b	347	if(!isGV(cvgv)) {
	348	cxix = __dopoptosub_at(ccstack, cxix - 1);
	349	continue;
	350	}
b23e9cb9	351
5efa8a5b	352	/* we found a real sub here */
5efa8a5b	353	sv = sv_2mortal(newSV(0));
b23e9cb9	354
5efa8a5b	355	gv_efullname3(sv, cvgv, NULL);
b23e9cb9	356
5efa8a5b	357	fq_subname = SvPVX(sv);
5efa8a5b	358	fq_subname_len = SvCUR(sv);
b23e9cb9	359
5efa8a5b	360	subname = strrchr(fq_subname, ':');
	361	if(!subname)
	362	Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
b23e9cb9	363
5efa8a5b	364	subname++;
	365	subname_len = fq_subname_len - (subname - fq_subname);
	366	if(subname_len == 8 && strEQ(subname, "__ANON__")) {
	367	cxix = __dopoptosub_at(ccstack, cxix - 1);
	368	continue;
	369	}
	370	break;
b23e9cb9	371	}
5efa8a5b	372	cxix--;
b23e9cb9	373	}
	374
	375	/* If we made it to here, we found our context */
	376
22c6f594	377	/* cachekey = "objpkg\|context::method::name" */
	378	cachekey = sv_2mortal(newSVpv(hvname, 0));
	379	sv_catpvn(cachekey, "\|", 1);
	380	sv_catsv(cachekey, sv);
b23e9cb9	381
6c88cc6a	382	nmcache = get_hv("next::METHOD_CACHE", 1);
22c6f594	383	if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
b23e9cb9	384	SV* val = HeVAL(cache_entry);
	385	if(val == &PL_sv_undef) {
	386	if(throw_nomethod)
625e16df	387	Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
2605e591	388	XSRETURN_EMPTY;
b23e9cb9	389	}
2605e591	390	XPUSHs(sv_2mortal(newRV_inc(val)));
2605e591	391	XSRETURN(1);
b23e9cb9	392	}
b23e9cb9	393
	394	/* beyond here is just for cache misses, so perf isn't as critical */
	395
	396	stashname_len = subname - fq_subname - 2;
	397	stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
	398
62eb9d08	399	linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
b23e9cb9	400
b23e9cb9	401	linear_svp = AvARRAY(linear_av);
2605e591	402	entries = AvFILLp(linear_av) + 1;
b23e9cb9	403
2605e591	404	while (entries--) {
053556af	405	SV* const linear_sv = *linear_svp++;
b23e9cb9	406	assert(linear_sv);
	407	if(sv_eq(linear_sv, stashname))
	408	break;
	409	}
	410
2605e591	411	if(entries > 0) {
29e61e10	412	SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
29e61e10	413	HV* cc3_mro = get_hv("Class::C3::MRO", 0);
29e61e10	414
2605e591	415	while (entries--) {
053556af	416	SV* const linear_sv = *linear_svp++;
b23e9cb9	417	assert(linear_sv);
29e61e10	418
	419	if(cc3_mro) {
	420	HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
	421	if(he_cc3_mro_class) {
3499e05c	422	SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
	423	if(SvROK(cc3_mro_class_sv)) {
	424	HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
	425	SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
	426	if(svp_cc3_mro_class_methods) {
	427	SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
	428	if(SvROK(cc3_mro_class_methods_sv)) {
	429	HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
	430	if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
	431	continue;
	432	}
	433	}
29e61e10	434	}
	435	}
	436	}
	437
b23e9cb9	438	cstash = gv_stashsv(linear_sv, FALSE);
	439
	440	if (!cstash) {
	441	if (ckWARN(WARN_MISC))
	442	Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
	443	(void*)linear_sv, hvname);
	444	continue;
	445	}
	446
	447	assert(cstash);
	448
b23e9cb9	449	gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
	450	if (!gvp) continue;
	451
	452	candidate = *gvp;
	453	assert(candidate);
	454
	455	if (SvTYPE(candidate) != SVt_PVGV)
	456	gv_init(candidate, cstash, subname, subname_len, TRUE);
	457	if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
62eb9d08	458	SvREFCNT_dec(linear_av);
b23e9cb9	459	SvREFCNT_inc((SV*)cand_cv);
22c6f594	460	hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0);
2605e591	461	XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
2605e591	462	XSRETURN(1);
b23e9cb9	463	}
	464	}
	465	}
	466
62eb9d08	467	SvREFCNT_dec(linear_av);
22c6f594	468	hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0);
b23e9cb9	469	if(throw_nomethod)
625e16df	470	Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
2605e591	471	XSRETURN_EMPTY;
b23e9cb9	472	}
	473
	474	XS(XS_Class_C3_XS_calculateMRO);
	475	XS(XS_Class_C3_XS_calculateMRO)
	476	{
b23e9cb9	477	dVAR; dXSARGS;
b23e9cb9	478
	479	SV* classname;
	480	HV* class_stash;
	481	HV* cache = NULL;
	482	AV* res;
	483	I32 res_items;
	484	I32 ret_items;
	485	SV** res_ptr;
	486
	487	if(items < 1 \|\| items > 2)
	488	croak("Usage: calculateMRO(classname[, cache])");
	489
	490	classname = ST(0);
f0294f1b	491	if(items == 2) cache = (HV*)SvRV(ST(1));
b23e9cb9	492
b23e9cb9	493	class_stash = gv_stashsv(classname, 0);
625e16df	494	if(!class_stash)
625e16df	495	Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
b23e9cb9	496
62eb9d08	497	res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
b23e9cb9	498
b23e9cb9	499	res_items = ret_items = AvFILLp(res) + 1;
	500	res_ptr = AvARRAY(res);
	501
	502	SP -= items;
	503
	504	while(res_items--) {
	505	SV* res_item = *res_ptr++;
62eb9d08	506	XPUSHs(sv_2mortal(newSVsv(res_item)));
b23e9cb9	507	}
62eb9d08	508	SvREFCNT_dec(res);
b23e9cb9	509
	510	PUTBACK;
	511
	512	return;
	513	}
	514
8feecaf9	515	XS(XS_Class_C3_XS_plsubgen);
	516	XS(XS_Class_C3_XS_plsubgen)
	517	{
25dc7e96	518	dVAR; dXSARGS;
8feecaf9	519
	520	SP -= items;
	521	XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
	522	PUTBACK;
	523	return;
	524	}
	525
625e16df	526	XS(XS_Class_C3_XS_calc_mdt);
	527	XS(XS_Class_C3_XS_calc_mdt)
	528	{
625e16df	529	dVAR; dXSARGS;
625e16df	530
	531	SV* classname;
	532	HV* cache;
	533	HV* class_stash;
	534	AV* class_mro;
	535	HV* our_c3mro; /* $Class::C3::MRO{classname} */
79782a49	536	SV* has_ovf = NULL;
625e16df	537	HV* methods;
	538	I32 mroitems;
	539
	540	/* temps */
	541	HV* hv;
	542	HE* he;
625e16df	543	SV** svp;
	544
	545	if(items < 1 \|\| items > 2)
	546	croak("Usage: calculate_method_dispatch_table(classname[, cache])");
	547
	548	classname = ST(0);
	549	class_stash = gv_stashsv(classname, 0);
	550	if(!class_stash)
	551	Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
	552
	553	if(items == 2) cache = (HV*)SvRV(ST(1));
	554
	555	class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
	556
	557	our_c3mro = newHV();
bb82f0c1	558	hv_store(our_c3mro, "MRO", 3, (SV)newRV_noinc((SV)class_mro), 0);
625e16df	559
	560	hv = get_hv("Class::C3::MRO", 1);
	561	hv_store_ent(hv, classname, (SV)newRV_noinc((SV)our_c3mro), 0);
	562
	563	methods = newHV();
	564
	565	/* skip first entry */
	566	mroitems = AvFILLp(class_mro);
	567	svp = AvARRAY(class_mro) + 1;
	568	while(mroitems--) {
	569	SV* mro_class = *svp++;
	570	HV* mro_stash = gv_stashsv(mro_class, 0);
	571
	572	if(!mro_stash) continue;
	573
79782a49	574	if(!has_ovf) {
625e16df	575	SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
625e16df	576	if(ovfp) has_ovf = *ovfp;
79782a49	577	}
625e16df	578
	579	hv_iterinit(mro_stash);
	580	while(he = hv_iternext(mro_stash)) {
	581	CV* code;
	582	SV* mskey;
79782a49	583	SV* msval;
	584	HE* ourent;
	585	HV* meth_hash;
	586	SV* orig;
625e16df	587
	588	mskey = hv_iterkeysv(he);
	589	if(hv_exists_ent(methods, mskey, 0)) continue;
79782a49	590
	591	msval = hv_iterval(mro_stash, he);
	592	if(SvTYPE(msval) != SVt_PVGV \|\| !(code = GvCVu(msval)))
	593	continue;
	594
	595	if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
	596	SV* val = HeVAL(ourent);
	597	if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
625e16df	598	continue;
	599	}
	600
79782a49	601	meth_hash = newHV();
	602	orig = newSVsv(mro_class);
	603	sv_catpvn(orig, "::", 2);
	604	sv_catsv(orig, mskey);
	605	hv_store(meth_hash, "orig", 4, orig, 0);
	606	hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0);
	607	hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0);
625e16df	608	}
	609	}
	610
	611	hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0);
79782a49	612	if(has_ovf) hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0);
625e16df	613	XSRETURN_EMPTY;
	614	}
	615
b23e9cb9	616	MODULE = Class::C3::XS PACKAGE = Class::C3::XS
	617
	618	BOOT:
	619	newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
8feecaf9	620	newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
625e16df	621	newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
2605e591	622	newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);
625e16df	623