#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) {
- if(!hv_store_ent(tails, seqitem, newSViv(1), 0)) {
- croak("failed to store value in hash");
- }
- }
- 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);
- sv_inc(val);
+ /* For 5.8.0 and later, sv_inc() with increment undef to
+ an IV of 1, which is what we want for a newly created
+ entry. However, for 5.6.x it will become an NV of
+ 1.0, which confuses the SvIVX() checks above */
+ if(SvIOK(val)) {
+ SvIVX(val)++;
+ } else {
+ sv_setiv(val, 1);
+ }
+ } 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);
}
/* 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);
- if (!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)));
}
SvREFCNT_dec(linear_av);
- if (!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)
XSRETURN_EMPTY;
}
-MODULE = Class::C3::XS PACKAGE = Class::C3::XS
+MODULE = Class::C3::XS PACKAGE = Class::C3::XS
PROTOTYPES: DISABLED
projects / gitmo/Class-C3-XS.git / blobdiff