X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=xs-src%2FMouseUtil.xs;h=3ec7d8cf4a4bc7a737ee9f96a7d349855cb1d8a4;hb=31aa6299ca20515174f1b145e5b3d4dbd9e09a08;hp=8704d89cac03dbbbb7fa85e4afc0b8d86109e4fb;hpb=0ffc4183de68b15deeec5d662d9cc1d125dabf26;p=gitmo%2FMouse.git diff --git a/xs-src/MouseUtil.xs b/xs-src/MouseUtil.xs index 8704d89..3ec7d8c 100644 --- a/xs-src/MouseUtil.xs +++ b/xs-src/MouseUtil.xs @@ -91,8 +91,6 @@ mouse_throw_error(SV* const metaobject, SV* const data /* not used */, const cha va_list args; SV* message; - PERL_UNUSED_ARG(data); /* for moose-compat */ - assert(metaobject); assert(fmt); @@ -103,21 +101,76 @@ mouse_throw_error(SV* const metaobject, SV* const data /* not used */, const cha { dSP; PUSHMARK(SP); - EXTEND(SP, 4); + EXTEND(SP, 6); PUSHs(metaobject); mPUSHs(message); - mPUSHs(newSVpvs("depth")); - mPUSHi(-1); - + if(data){ /* extra arg, might be useful for debugging */ + mPUSHs(newSVpvs("data")); + PUSHs(data); + mPUSHs(newSVpvs("depth")); + mPUSHi(-1); + } PUTBACK; - - call_method("throw_error", G_VOID); + if(SvOK(metaobject)) { + call_method("throw_error", G_VOID); + } + else { + call_pv("Mouse::Util::throw_error", G_VOID); + } croak("throw_error() did not throw the error (%"SVf")", message); } } +/* workaround Perl-RT #69939 */ +I32 +mouse_call_sv_safe(pTHX_ SV* const sv, I32 const flags) { + I32 count; + ENTER; + /* Don't do SAVETMPS */ + + SAVESPTR(ERRSV); + ERRSV = sv_newmortal(); + + count = Perl_call_sv(aTHX_ sv, flags | G_EVAL); + + if(sv_true(ERRSV)){ + SV* const err = sv_mortalcopy(ERRSV); + LEAVE; + sv_setsv(ERRSV, err); + croak(NULL); /* rethrow */ + } + + LEAVE; + + return count; +} + +void +mouse_must_defined(pTHX_ SV* const value, const char* const name) { + assert(value); + assert(name); + + SvGETMAGIC(value); + if(!SvOK(value)){ + croak("You must define %s", name); + } +} + +void +mouse_must_ref(pTHX_ SV* const value, const char* const name, svtype const t) { + assert(value); + assert(name); + + SvGETMAGIC(value); + if(!(SvROK(value) && (t == SVt_NULL || SvTYPE(SvRV(value)) == t))) { + croak("You must pass %s, not %s", + name, SvOK(value) ? SvPV_nolen(value) : "undef"); + } +} + + bool mouse_is_class_loaded(pTHX_ SV * const klass){ HV *stash; @@ -150,11 +203,13 @@ mouse_is_class_loaded(pTHX_ SV * const klass){ GV* const gv = (GV*)HeVAL(he); if(isGV(gv)){ - if(GvCVu(gv)){ + if(GvCVu(gv)){ /* is GV and has CV */ + hv_iterinit(stash); /* reset */ return TRUE; } } - else if(SvOK(gv)){ + else if(SvOK(gv)){ /* is a stub or constant */ + hv_iterinit(stash); /* reset */ return TRUE; } } @@ -171,7 +226,7 @@ mouse_call0 (pTHX_ SV* const self, SV* const method) { XPUSHs(self); PUTBACK; - call_sv(method, G_SCALAR | G_METHOD); + call_sv_safe(method, G_SCALAR | G_METHOD); SPAGAIN; ret = POPs; @@ -191,7 +246,7 @@ mouse_call1 (pTHX_ SV* const self, SV* const method, SV* const arg1) { PUSHs(arg1); PUTBACK; - call_sv(method, G_SCALAR | G_METHOD); + call_sv_safe(method, G_SCALAR | G_METHOD); SPAGAIN; ret = POPs; @@ -257,6 +312,50 @@ mouse_stash_fetch(pTHX_ HV* const stash, const char* const name, I32 const namel } } +void +mouse_install_sub(pTHX_ GV* const gv, SV* const code_ref) { + CV* cv; + + assert(gv != NULL); + assert(code_ref != NULL); + assert(isGV(gv)); + assert(IsCodeRef(code_ref)); + + if(GvCVu(gv)){ /* delete *slot{gv} to work around "redefine" warning */ + SvREFCNT_dec(GvCV(gv)); + GvCV_set(gv, NULL); + } + + sv_setsv_mg((SV*)gv, code_ref); /* *gv = $code_ref */ + + /* name the CODE ref if it's anonymous */ + cv = (CV*)SvRV(code_ref); + if(CvANON(cv) + && CvGV(cv) /* a cv under construction has no gv */ ){ + HV* dbsub; + + /* update %DB::sub to make NYTProf happy */ + if((PL_perldb & (PERLDBf_SUBLINE|PERLDB_NAMEANON)) + && PL_DBsub && (dbsub = GvHV(PL_DBsub)) + ){ + /* see Perl_newATTRSUB() in op.c */ + SV* const subname = sv_newmortal(); + HE* orig; + + gv_efullname3(subname, CvGV(cv), NULL); + orig = hv_fetch_ent(dbsub, subname, FALSE, 0U); + if(orig){ + gv_efullname3(subname, gv, NULL); + (void)hv_store_ent(dbsub, subname, HeVAL(orig), 0U); + SvREFCNT_inc_simple_void_NN(HeVAL(orig)); + } + } + + CvGV_set(cv, gv); + CvANON_off(cv); + } +} + MODULE = Mouse::Util PACKAGE = Mouse::Util PROTOTYPES: DISABLE @@ -278,7 +377,9 @@ CODE: } { dMY_CXT; - if(MY_CXT.metas) croak("Cannot set metaclass storage more than once"); + if(MY_CXT.metas && ckWARN(WARN_REDEFINE)){ + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Metaclass storage more than once"); + } MY_CXT.metas = metas; SvREFCNT_inc_simple_void_NN(metas); } @@ -345,12 +446,8 @@ CODE: const char* name_pv; GV* gv; - if(!SvOK(package)){ - croak("You must define a package name"); - } - if(!SvOK(name)){ - croak("You must define a subroutine name"); - } + must_defined(package, "a package name"); + must_defined(name, "a subroutine name"); stash = gv_stashsv(package, FALSE); if(!stash){ @@ -378,17 +475,10 @@ PPCODE: const char* name_pv = NULL; CV* xsub; - SvGETMAGIC(arg); - - if(!SvOK(arg)){ - croak("You must define %s", ix == 0 ? "a class name" : "method names"); - } + must_defined(arg, ix == 0 ? "a class_name" : "method names"); if(predicate_name){ - SvGETMAGIC(predicate_name); - if(!SvOK(predicate_name)){ - croak("You must define %s", "a predicate name"); - } + must_defined(predicate_name, "a predicate name"); name_pv = SvPV_nolen_const(predicate_name); } @@ -403,3 +493,35 @@ PPCODE: mXPUSHs( newRV_inc((SV*)xsub) ); } } + +# This xsub will redefine &Mouse::Util::install_subroutines() +void +install_subroutines(SV* into, ...) +CODE: +{ + HV* stash; + I32 i; + + must_defined(into, "a package name"); + stash = gv_stashsv(into, TRUE); + + if( ((items-1) % 2) != 0 ){ + croak_xs_usage(cv, "into, name => coderef [, other_name, other_coderef ...]"); + } + + for(i = 1; i < items; i += 2) { + SV* const name = ST(i); + SV* const code = ST(i+1); + STRLEN len; + const char* pv; + GV* gv; + + must_defined(name, "a subroutine name"); + must_ref(code, "a CODE reference", SVt_PVCV); + + pv = SvPV_const(name, len); + gv = stash_fetch(stash, pv, len, TRUE); + + mouse_install_sub(aTHX_ gv, code); + } +}