[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 */

#ifndef SVfARG
#  define SVfARG(p)                      ((void*)(p))
#endif

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

                if(items == 0 && AvFILLp(seqs) == -1) {
                    /* Only one parent class. For this case, the C3
                       linearisation is this class followed by the parent's
                       linearisation, so don't bother with the expensive
                       calculation.  */
                    SV **svp;
                    I32 subrv_items = AvFILLp(isa_lin) + 1;
                    SV *const *subrv_p = AvARRAY(isa_lin);

                    /* Hijack the allocated but unused array seqs to be the
                       return value. It's currently mortalised.  */

                    retval = seqs;

                    av_extend(retval, subrv_items);
                    AvFILLp(retval) = subrv_items;
                    svp = AvARRAY(retval);

                    /* First entry is this class.  */
                    *svp++ = newSVpvn(stashname, stashname_len);

                    while(subrv_items--) {
                        /* These values are unlikely to be shared hash key
                           scalars, so no point in adding code to optimising
                           for a case that is unlikely to be true.
                           (Or prove me wrong and do it.)  */

                        SV *const val = *subrv_p++;
                        *svp++ = newSVsv(val);
                    }

                    SvREFCNT_dec(isa_lin);
                    SvREFCNT_inc(retval);

                    goto done;
                }
                av_push(seqs, (SV*)isa_lin);
            }
        }
        av_push(seqs, SvREFCNT_inc((SV*)isa));
        tails = (HV*)sv_2mortal((SV*)newHV());

        /* 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) {
                        if(!hv_store_ent(tails, seqitem, newSViv(1), 0)) {
                            croak("failed to store value in hash");
                        }
                    }
                    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) {
                SV *errmsg;
                I32 i;
                /* we have to do some cleanup before we croak */

                errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
                                  "current merge results [\n", stashname);
                for (i = 0; i <= av_len(retval); i++) {
                    SV **elem = av_fetch(retval, i, 0);
                    sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
                }
                sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));

                SvREFCNT_dec(retval);
                Safefree(heads);

                croak("%"SVf, SVfARG(errmsg));
            }
        }
    }
    else { /* @ISA was undefined or empty */
        /* build a retval containing only ourselves */
        retval = newAV();
        av_push(retval, newSVpvn(stashname, stashname_len));
    }

done:
    /* 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);
        if(!hv_store(cache, stashname, stashname_len, (SV*)retval, 0)) {
            croak("failed to store value in hash");
        }
    }

    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;
    I32 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);
                if (!hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0)) {
                    croak("failed to store value in hash");
                }
                XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
                XSRETURN(1);
            }
        }
    }

    SvREFCNT_dec(linear_av);
    if (!hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0)) {
        croak("failed to store value in hash");
    }
    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();
    if(!hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0)) {
        croak("failed to store value in hash");
    }

    hv = get_hv("Class::C3::MRO", 1);
    if(!hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0)) {
        croak("failed to store value in hash");
    }

    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);
            if( !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) ) {
                croak("failed to store value in hash");
            }
        }
    }

    if(!hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0)) {
        croak("failed to store value in hash");
    }
    if(has_ovf) {
        if(!hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0)) {
            croak("failed to store value in hash");
        }
    }
    XSRETURN_EMPTY;
}

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

PROTOTYPES: DISABLED

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