#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;
}
/* we found a real sub here */
- sv = sv_2mortal(newSV(0));
+ sv = sv_newmortal();
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, ':');
+ } else {
+ subname = NULL;
+ }
subname = strrchr(fq_subname, ':');
if(!subname)
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();
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