#ifndef SvREFCNT_inc
# ifdef PERL_USE_GCC_BRACE_GROUPS
-# define SvREFCNT_inc(sv) \
- ({ \
- SV * const _sv = (SV*)(sv); \
- if (_sv) \
- (SvREFCNT(_sv))++; \
- _sv; \
+# define SvREFCNT_inc(sv) \
+ ({ \
+ SV * const _sv = (SV*)(sv); \
+ if (_sv) \
+ (SvREFCNT(_sv))++; \
+ _sv; \
})
# else
-# define SvREFCNT_inc(sv) \
+# define SvREFCNT_inc(sv) \
((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL)
# endif
#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.
if(isa && AvFILLp(isa) >= 0) {
SV** seqs_ptr;
I32 seqs_items;
- HV* const tails = (HV*)sv_2mortal((SV*)newHV());
+ HV* tails;
AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
I32* heads;
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"
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 {
+ /* 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");
}
}
}
/* 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);
- Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
- "merging failed on parent '%s'", stashname, SvPV_nolen(cand));
+ croak("%"SVf, SVfARG(errmsg));
}
}
}
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);
- hv_store(cache, stashname, stashname_len, (SV*)retval, 0);
+ if(!hv_store(cache, stashname, stashname_len, (SV*)retval, 0)) {
+ croak("failed to store value in hash");
+ }
}
return retval;
{
dVAR; dXSARGS;
- SV* self;
- I32 throw_nomethod;
- register I32 cxix;
+ 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;
HV* nmcache;
HE* cache_entry;
SV* cachekey;
-
- self = ST(0);
- throw_nomethod = SvIVX(ST(1));
+ I32 i;
SP -= items;
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);
-
/* 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);
- }
+ 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)
- Perl_croak(aTHX_ "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 */
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);
+ 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);
}
}
SvREFCNT_dec(linear_av);
- hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0);
+ if (!hv_store_ent(nmcache, 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;
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);
+ 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);
- hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0);
+ if(!hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0)) {
+ croak("failed to store value in hash");
+ }
methods = newHV();
}
hv_iterinit(mro_stash);
- while(he = hv_iternext(mro_stash)) {
+ while((he = hv_iternext(mro_stash))) {
CV* code;
SV* mskey;
SV* msval;
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);
+ 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");
+ }
}
}
- 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);
+ 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__);