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

    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); /* skip next::method, etc */

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