#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* isa;
const char* stashname;
STRLEN stashname_len;
+ I32 made_mortal_cache = 0;
assert(stash);
if(!cache) {
cache = (HV*)sv_2mortal((SV*)newHV());
+ made_mortal_cache = 1;
}
else {
SV** cache_entry = hv_fetch(cache, stashname, stashname_len, 0);
/* not in cache, make a new one */
- retval = (AV*)sv_2mortal((SV*)newAV());
- av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
-
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 = (HV*)sv_2mortal((SV*)newHV());
- AV* seqs = (AV*)sv_2mortal((SV*)newAV());
+ 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--) {
- AV* isa_lin;
- SV* isa_item = *isa_ptr++;
- HV* isa_item_stash = gv_stashsv(isa_item, 0);
+ SV* const isa_item = *isa_ptr++;
+ HV* const isa_item_stash = gv_stashsv(isa_item, 0);
if(!isa_item_stash) {
- isa_lin = newAV();
+ /* 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 {
- isa_lin = (AV*)sv_2mortal((SV*)__mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1)); /* recursion */
+ /* 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, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin)));
}
- av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
-
+ 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* seq = (AV*)*seqs_ptr++;
+ 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* seqitem = *seq_ptr++;
- HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
- if(!he) {
- hv_store_ent(tails, seqitem, newSViv(1), 0);
- }
- else {
- SV* val = HeVAL(he);
+ SV* const seqitem = *seq_ptr++;
+ /* LVALUE fetch will create a new undefined SV if necessary
+ */
+ HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
+ if(he) {
+ SV* const val = HeVAL(he);
+ /* This will increment undef to 1, which is what we
+ want for a newly created entry. */
sv_inc(val);
+ } else {
+ croak("failed to store value in hash");
}
}
}
}
+ /* 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* seqhead = NULL;
SV* cand = NULL;
SV* winner = NULL;
- SV* val;
- HE* tail_entry;
- AV* seq;
- SV** avptr = AvARRAY(seqs);
- items = AvFILLp(seqs)+1;
- while(items--) {
+ int s;
+
+ /* "foreach $seq (@seqs)" */
+ SV** const avptr = AvARRAY(seqs);
+ for(s = 0; s <= AvFILLp(seqs); s++) {
SV** svp;
- seq = (AV*)*avptr++;
- if(AvFILLp(seq) < 0) continue;
- svp = av_fetch(seq, 0, 0);
- seqhead = *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))
+ && (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)) {
- sv_2mortal(av_shift(seq));
- if(AvFILLp(seq) < 0) continue;
- svp = av_fetch(seq, 0, 0);
- seqhead = *svp;
- tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
- val = HeVAL(tail_entry);
- sv_dec(val);
+ /* 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(!cand) break;
- if(!winner)
- Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
- "merging failed on parent '%s'", stashname, SvPV_nolen(cand));
+
+ /* 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);
- SvREFCNT_inc(retval); /* for cache storage */
- SvREFCNT_inc(retval); /* for return */
- hv_store(cache, stashname, stashname_len, (SV*)retval, 0);
+
+ 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;
}
return i;
}
-STATIC SV*
-__nextcan(pTHX_ SV* self, I32 throw_nomethod)
+XS(XS_Class_C3_XS_nextcan);
+XS(XS_Class_C3_XS_nextcan)
{
- register I32 cxix;
+ 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** gvp;
AV* linear_av;
SV** linear_svp;
- SV* linear_sv;
HV* cstash;
GV* candidate = NULL;
CV* cand_cv = NULL;
const char *hvname;
- I32 items;
+ I32 entries;
HV* nmcache;
HE* cache_entry;
SV* cachekey;
+ I32 i;
+
+ SP -= items;
if(sv_isobject(self))
selfstash = SvSTASH(SvRV(self));
hvname = HvNAME(selfstash);
if (!hvname)
- croak("Can't use anonymous symbol table for method lookup");
-
- cxix = __dopoptosub_at(cxstack, cxstack_ix);
+ 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 */
- for (;;) {
- /* we may be in a higher stacklevel, so dig down deeper */
- while (cxix < 0) {
- if(top_si->si_type == PERLSI_MAIN)
- croak("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);
- }
+ 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;
- }
+ 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;
+ {
+ 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);
+ cvgv = CvGV(ccstack[cxix].blk_sub.cv);
- if(!isGV(cvgv)) {
- cxix = __dopoptosub_at(ccstack, cxix - 1);
- continue;
- }
+ if(!isGV(cvgv)) {
+ cxix = __dopoptosub_at(ccstack, cxix - 1);
+ continue;
+ }
- /* we found a real sub here */
- sv = sv_2mortal(newSV(0));
+ /* we found a real sub here */
+ sv = sv_newmortal();
- gv_efullname3(sv, cvgv, NULL);
+ gv_efullname3(sv, cvgv, NULL);
- fq_subname = SvPVX(sv);
- fq_subname_len = SvCUR(sv);
+ if (SvPOK(sv)) {
+ fq_subname = SvPVX(sv);
+ fq_subname_len = SvCUR(sv);
- subname = strrchr(fq_subname, ':');
- if(!subname)
- croak("next::method/next::can/maybe::next::method cannot find enclosing method");
+ subname = strrchr(fq_subname, ':');
+ } else {
+ subname = NULL;
+ }
+
+ 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;
+ subname++;
+ subname_len = fq_subname_len - (subname - fq_subname);
+ if(subname_len == 8 && strEQ(subname, "__ANON__")) {
+ cxix = __dopoptosub_at(ccstack, cxix - 1);
+ continue;
+ }
+ break;
}
- break;
+ cxix--;
}
/* If we made it to here, we found our context */
SV* val = HeVAL(cache_entry);
if(val == &PL_sv_undef) {
if(throw_nomethod)
- croak("No next::method '%s' found for %s", subname, hvname);
- return &PL_sv_undef;
+ Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
+ XSRETURN_EMPTY;
}
- return SvREFCNT_inc(val);
+ 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 = (AV*)sv_2mortal((SV*)__mro_linear_isa_c3(aTHX_ selfstash, NULL, 0));
+ linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
linear_svp = AvARRAY(linear_av);
- items = AvFILLp(linear_av) + 1;
+ entries = AvFILLp(linear_av) + 1;
- while (items--) {
- linear_sv = *linear_svp++;
+ while (entries--) {
+ SV* const linear_sv = *linear_svp++;
assert(linear_sv);
if(sv_eq(linear_sv, stashname))
break;
}
- if(items > 0) {
+ if(entries > 0) {
SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
HV* cc3_mro = get_hv("Class::C3::MRO", 0);
- while (items--) {
- linear_sv = *linear_svp++;
+ while (entries--) {
+ SV* const linear_sv = *linear_svp++;
assert(linear_sv);
if(cc3_mro) {
if (SvTYPE(candidate) != SVt_PVGV)
gv_init(candidate, cstash, subname, subname_len, TRUE);
if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
+ SvREFCNT_dec(linear_av);
SvREFCNT_inc((SV*)cand_cv);
- hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0);
- return (SV*)cand_cv;
+ if (!hv_store_ent(nmcache, cachekey, (SV*)cand_cv, 0)) {
+ croak("failed to store value in hash");
+ }
+ XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
+ XSRETURN(1);
}
}
}
- hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0);
+ SvREFCNT_dec(linear_av);
+ if (!hv_store_ent(nmcache, cachekey, &PL_sv_undef, 0)) {
+ croak("failed to store value in hash");
+ }
if(throw_nomethod)
- croak("No next::method '%s' found for %s", subname, hvname);
- return &PL_sv_undef;
+ 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)
{
-#ifdef dVAR
dVAR; dXSARGS;
-#else
- dXSARGS;
-#endif
SV* classname;
HV* class_stash;
if(items == 2) cache = (HV*)SvRV(ST(1));
class_stash = gv_stashsv(classname, 0);
- if(!class_stash) croak("No such class: '%s'!", SvPV_nolen(classname));
+ if(!class_stash)
+ Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
- res = (AV*)sv_2mortal((SV*)__mro_linear_isa_c3(aTHX_ class_stash, cache, 0));
+ res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
res_items = ret_items = AvFILLp(res) + 1;
res_ptr = AvARRAY(res);
while(res_items--) {
SV* res_item = *res_ptr++;
- XPUSHs(res_item);
+ XPUSHs(sv_2mortal(newSVsv(res_item)));
}
+ SvREFCNT_dec(res);
PUTBACK;
return;
}
-XS(XS_next_can);
-XS(XS_next_can)
+XS(XS_Class_C3_XS_plsubgen);
+XS(XS_Class_C3_XS_plsubgen)
{
-#ifdef dVAR
dVAR; dXSARGS;
-#else
- dXSARGS;
-#endif
- SV* self = ST(0);
- SV* methcv = __nextcan(aTHX_ self, 0);
+ 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;
- PERL_UNUSED_VAR(items);
+ 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;
- if(methcv == &PL_sv_undef) {
- ST(0) = &PL_sv_undef;
+ /* 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");
}
- else {
- ST(0) = sv_2mortal(newRV_inc(methcv));
+
+ 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");
}
- XSRETURN(1);
-}
+ methods = newHV();
-XS(XS_next_method);
-XS(XS_next_method)
-{
- dMARK;
- dAX;
- SV* self = ST(0);
- SV* methcv = __nextcan(aTHX_ self, 1);
+ /* 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);
- PL_markstack_ptr++;
- call_sv(methcv, GIMME_V);
-}
+ if(!mro_stash) continue;
-XS(XS_maybe_next_method);
-XS(XS_maybe_next_method)
-{
- dMARK;
- dAX;
- SV* self = ST(0);
- SV* methcv = __nextcan(aTHX_ self, 0);
+ if(!has_ovf) {
+ SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
+ if(ovfp) has_ovf = *ovfp;
+ }
- if(methcv == &PL_sv_undef) {
- ST(0) = &PL_sv_undef;
- XSRETURN(1);
+ 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");
+ }
+ }
}
- PL_markstack_ptr++;
- call_sv(methcv, GIMME_V);
+ 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
+MODULE = Class::C3::XS PACKAGE = Class::C3::XS
+
+PROTOTYPES: DISABLED
BOOT:
newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
- newXS("next::can", XS_next_can, __FILE__);
- newXS("next::method", XS_next_method, __FILE__);
- newXS("maybe::next::method", XS_maybe_next_method, __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__);
+