#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.
I32 made_mortal_cache = 0;
assert(stash);
- assert(HvAUX(stash));
stashname = HvNAME(stash);
stashname_len = strlen(stashname);
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;
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 {
- AV* const isa_lin = __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);
av_push(seqs, (SV*)isa_lin);
}
}
/* 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
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;
+ if(!seq) continue; /* skip empty seqs */
svp = av_fetch(seq, heads[s], 0);
- seqhead = *svp;
+ 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)) {
+ /* 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]);
}
}
}
+
+ /* 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 does not exist, or was empty */
+ else { /* @ISA was undefined or empty */
+ /* build a retval containing only ourselves */
retval = newAV();
- av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
+ 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) {
return i;
}
-STATIC SV*
-__nextcan(pTHX_ SV* self, I32 throw_nomethod)
+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;
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;
+ SP -= items;
+
if(sv_isobject(self))
selfstash = SvSTASH(SvRV(self));
else
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
if(val == &PL_sv_undef) {
if(throw_nomethod)
Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
- return &PL_sv_undef;
+ 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 */
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) {
SvREFCNT_dec(linear_av);
SvREFCNT_inc((SV*)cand_cv);
hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0);
- return (SV*)cand_cv;
+ XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
+ XSRETURN(1);
}
}
}
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);
- return &PL_sv_undef;
+ 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;
XS(XS_Class_C3_XS_plsubgen);
XS(XS_Class_C3_XS_plsubgen)
{
- #ifdef dVAR
- dVAR; dXSARGS;
- #else
- dXSARGS;
- #endif
+ dVAR; dXSARGS;
SP -= items;
XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
XS(XS_Class_C3_XS_calc_mdt);
XS(XS_Class_C3_XS_calc_mdt)
{
-#ifdef dVAR
dVAR; dXSARGS;
-#else
- dXSARGS;
-#endif
SV* classname;
HV* cache;
XSRETURN_EMPTY;
}
-XS(XS_next_can);
-XS(XS_next_can)
-{
-#ifdef dVAR
- dVAR; dXSARGS;
-#else
- dXSARGS;
-#endif
-
- SV* self = ST(0);
- SV* methcv = __nextcan(aTHX_ self, 0);
-
- PERL_UNUSED_VAR(items);
-
- if(methcv == &PL_sv_undef) {
- ST(0) = &PL_sv_undef;
- }
- else {
- ST(0) = sv_2mortal(newRV_inc(methcv));
- }
-
- XSRETURN(1);
-}
-
-XS(XS_next_method);
-XS(XS_next_method)
-{
- dMARK;
- dAX;
- SV* self = ST(0);
- SV* methcv = __nextcan(aTHX_ self, 1);
-
- PL_markstack_ptr++;
- call_sv(methcv, GIMME_V);
-}
-
-XS(XS_maybe_next_method);
-XS(XS_maybe_next_method)
-{
- dMARK;
- dAX;
- SV* self = ST(0);
- SV* methcv = __nextcan(aTHX_ self, 0);
-
- if(methcv == &PL_sv_undef) {
- ST(0) = &PL_sv_undef;
- XSRETURN(1);
- }
-
- PL_markstack_ptr++;
- call_sv(methcv, GIMME_V);
-}
-
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("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::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);
projects / gitmo/Class-C3-XS.git / blobdiff