X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=XS.xs;h=4ced6b89dc389ae99d75de5c7278365b613e8767;hb=a2051bf948cf922e8b2f80580cb86ce56dc36e45;hp=9f7a63b63cb03ca91bec2553eac67f158d3a3cff;hpb=54d13ec684a9cbb0d1c52096631e92988e616578;p=gitmo%2FClass-C3-XS.git diff --git a/XS.xs b/XS.xs index 9f7a63b..4ced6b8 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. @@ -95,7 +99,7 @@ __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level) 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; @@ -118,10 +122,48 @@ __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level) 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" @@ -142,13 +184,16 @@ __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level) 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"); } } } @@ -229,13 +274,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)); } } } @@ -245,13 +299,16 @@ __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level) 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; @@ -350,12 +407,18 @@ XS(XS_Class_C3_XS_nextcan) } /* 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) @@ -457,7 +520,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, cachekey, (SV*)cand_cv, 0)) { + croak("failed to store value in hash"); + } XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv))); XSRETURN(1); } @@ -465,7 +530,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, 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; @@ -555,10 +622,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(); @@ -577,7 +648,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; @@ -602,18 +673,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__);