X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=XS.xs;h=9e360b232ebfad870e5bea252e3f7b0778ac841f;hb=7c72bb9db5bbefd87304ee9c581ffad2f0fdb5c5;hp=6acd791ebf08e90da525f7f516aedb5f7ea60b7c;hpb=053556af2954a716218645aff9e07c0f4276d405;p=gitmo%2FClass-C3-XS.git

diff --git a/XS.xs b/XS.xs
index 6acd791..9e360b2 100644
--- a/XS.xs
+++ b/XS.xs
@@ -3,6 +3,53 @@
 #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.
@@ -20,7 +67,6 @@ __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level)
     I32 made_mortal_cache = 0;
 
     assert(stash);
-    assert(HvAUX(stash));
 
     stashname = HvNAME(stash);
     stashname_len = strlen(stashname);
@@ -220,10 +266,14 @@ __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
     return i;
 }
 
-STATIC SV*
-__nextcan(pTHX_ SV* self, I32 throw_nomethod)
+XS(XS_Class_C3_XS_nextcan);
+XS(XS_Class_C3_XS_nextcan)
 {
-    register I32 cxix;
+    dVAR; dXSARGS;
+
+    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;
@@ -242,10 +292,13 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod)
     GV* candidate = NULL;
     CV* cand_cv = NULL;
     const char *hvname;
-    I32 items;
+    I32 entries;
     HV* nmcache;
     HE* cache_entry;
     SV* cachekey;
+    int i;
+
+    SP -= items;
 
     if(sv_isobject(self))
         selfstash = SvSTASH(SvRV(self));
@@ -258,63 +311,65 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod)
     if (!hvname)
         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 
-    cxix = __dopoptosub_at(cxstack, cxstack_ix);
-
     /* 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 */
@@ -330,9 +385,10 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod)
         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 */
@@ -343,20 +399,20 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod)
     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--) {
+    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--) {
+        while (entries--) {
             SV* const linear_sv = *linear_svp++;
             assert(linear_sv);
 
@@ -402,7 +458,8 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod)
                 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);
             }
         }
     }
@@ -411,17 +468,13 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod)
     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;
@@ -462,11 +515,7 @@ XS(XS_Class_C3_XS_calculateMRO)
 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)));
@@ -477,11 +526,7 @@ XS(XS_Class_C3_XS_plsubgen)
 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;
@@ -568,66 +613,11 @@ XS(XS_Class_C3_XS_calc_mdt)
     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__);