X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FClass-C3-XS.git;a=blobdiff_plain;f=XS.xs;h=1ad66143340ea15f7e9c8dc1813339fb2a8acb53;hp=f120168ff9b9dea318ea58ed409782cd9b742ab4;hb=eeeb4071329047dfee7aa27e4ec447f35e61e64a;hpb=2605e5915fb1dc1d8cd98585f16cb57d1df11c5b

diff --git a/XS.xs b/XS.xs
index f120168..1ad6614 100644
--- a/XS.xs
+++ b/XS.xs
@@ -23,15 +23,15 @@
 
 #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
@@ -50,6 +50,10 @@
 
 /* *********** 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.
@@ -144,7 +148,9 @@ __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level)
                     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);
+                        if(!hv_store_ent(tails, seqitem, newSViv(1), 0)) {
+                            croak("failed to store value in hash");
+                        }
                     }
                     else {
                         SV* const val = HeVAL(he);
@@ -229,13 +235,22 @@ __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level)
             /* 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));
             }
         }
     }
@@ -251,7 +266,9 @@ __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level)
 
     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;
@@ -271,9 +288,9 @@ XS(XS_Class_C3_XS_nextcan)
 {
     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;
@@ -296,9 +313,7 @@ XS(XS_Class_C3_XS_nextcan)
     HV* nmcache;
     HE* cache_entry;
     SV* cachekey;
-
-    self = ST(0);
-    throw_nomethod = SvIVX(ST(1));
+    I32 i;
 
     SP -= items;
 
@@ -313,64 +328,65 @@ XS(XS_Class_C3_XS_nextcan)
     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_2mortal(newSV(0));
 
-        gv_efullname3(sv, cvgv, NULL);
+            gv_efullname3(sv, cvgv, NULL);
 
-        fq_subname = SvPVX(sv);
-        fq_subname_len = SvCUR(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, ':');
+            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 */
@@ -458,7 +474,9 @@ XS(XS_Class_C3_XS_nextcan)
             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, newSVsv(cachekey), (SV*)cand_cv, 0)) {
+                    croak("failed to store value in hash");
+                }
                 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
                 XSRETURN(1);
             }
@@ -466,7 +484,9 @@ XS(XS_Class_C3_XS_nextcan)
     }
 
     SvREFCNT_dec(linear_av);
-    hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0);
+    if (!hv_store_ent(nmcache, newSVsv(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;
@@ -556,10 +576,14 @@ XS(XS_Class_C3_XS_calc_mdt)
     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();
 
@@ -578,7 +602,7 @@ XS(XS_Class_C3_XS_calc_mdt)
         }
 
         hv_iterinit(mro_stash);
-        while(he = hv_iternext(mro_stash)) {
+        while((he = hv_iternext(mro_stash))) {
             CV* code;
             SV* mskey;
             SV* msval;
@@ -603,18 +627,28 @@ XS(XS_Class_C3_XS_calc_mdt)
             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__);