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=6acd791ebf08e90da525f7f516aedb5f7ea60b7c;hb=eeeb4071329047dfee7aa27e4ec447f35e61e64a;hpb=053556af2954a716218645aff9e07c0f4276d405 diff --git a/XS.xs b/XS.xs index 6acd791..1ad6614 100644 --- a/XS.xs +++ b/XS.xs @@ -3,6 +3,57 @@ #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 */ + +#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. @@ -20,7 +71,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); @@ -98,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); @@ -183,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)); } } } @@ -205,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; @@ -220,10 +283,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 +309,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; + I32 i; + + SP -= items; if(sv_isobject(self)) selfstash = SvSTASH(SvRV(self)); @@ -258,63 +328,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 +402,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 +416,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); @@ -401,27 +474,28 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) 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); - return (SV*)cand_cv; + 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); } } } 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); - 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 +536,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 +547,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; @@ -510,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(); @@ -532,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; @@ -557,77 +627,32 @@ 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); - 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; + if(!hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0)) { + croak("failed to store value in hash"); } - else { - ST(0) = sv_2mortal(newRV_inc(methcv)); + 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(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); + XSRETURN_EMPTY; } -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 -MODULE = Class::C3::XS PACKAGE = Class::C3::XS +PROTOTYPES: DISABLED 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__);