X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=xs-src%2FMouseUtil.xs;h=fad81d0575059ae38d5c256ad1bf1aa9b677e04d;hp=f99c6f6a1e9a0a11b3bbda5cbb1b3b783463e361;hb=d06d926635763fa5687c429b5ad39938c564fbed;hpb=0aad026606f2d1d5d27cfb8824dd182f790fa9e2

diff --git a/xs-src/MouseUtil.xs b/xs-src/MouseUtil.xs
index f99c6f6..fad81d0 100644
--- a/xs-src/MouseUtil.xs
+++ b/xs-src/MouseUtil.xs
@@ -1,5 +1,11 @@
 #include "mouse.h"
 
+#define MY_CXT_KEY "Mouse::Util::_guts" XS_VERSION
+typedef struct {
+    HV* metas;
+} my_cxt_t;
+START_MY_CXT
+
 #define ISA_CACHE "::LINEALIZED_ISA_CACHE::"
 
 #ifdef no_mro_get_linear_isa
@@ -85,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);
 
@@ -97,13 +101,17 @@ 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;
 
@@ -112,6 +120,30 @@ mouse_throw_error(SV* const metaobject, SV* const data /* not used */, const cha
     }
 }
 
+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;
@@ -196,35 +228,27 @@ mouse_call1 (pTHX_ SV* const self, SV* const method, SV* const arg1) {
 
 int
 mouse_predicate_call(pTHX_ SV* const self, SV* const method) {
-    SV* const value = mcall0(self, method);
-    return SvTRUE(value);
+    return sv_true( mcall0(self, method) );
 }
 
 SV*
 mouse_get_metaclass(pTHX_ SV* metaclass_name){
-    CV* const get_metaclass  = get_cvs("Mouse::Util::get_metaclass_by_name", TRUE);
-    SV* metaclass;
-    dSP;
+    dMY_CXT;
+    HE* he;
 
     assert(metaclass_name);
+    assert(MY_CXT.metas);
+
     if(IsObject(metaclass_name)){
-        HV* const stash = SvSTASH(metaclass_name);
+        HV* const stash = SvSTASH(SvRV(metaclass_name));
 
         metaclass_name = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
         sv_2mortal(metaclass_name);
     }
 
-    PUSHMARK(SP);
-    XPUSHs(metaclass_name);
-    PUTBACK;
+    he = hv_fetch_ent(MY_CXT.metas, metaclass_name, FALSE, 0U);
 
-    call_sv((SV*)get_metaclass, G_SCALAR);
-
-    SPAGAIN;
-    metaclass = POPs;
-    PUTBACK;
-
-    return metaclass;
+    return he ? HeVAL(he) : &PL_sv_undef;
 }
 
 MAGIC*
@@ -259,11 +283,100 @@ 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(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(cv) = gv;
+        CvANON_off(cv);
+    }
+}
+
 MODULE = Mouse::Util  PACKAGE = Mouse::Util
 
 PROTOTYPES:   DISABLE
 VERSIONCHECK: DISABLE
 
+BOOT:
+{
+    MY_CXT_INIT;
+    MY_CXT.metas = NULL;
+}
+
+void
+__register_metaclass_storage(HV* metas, bool cloning)
+CODE:
+{
+    if(cloning){
+        MY_CXT_CLONE;
+        MY_CXT.metas = NULL;
+    }
+    {
+        dMY_CXT;
+        if(MY_CXT.metas) croak("Cannot set metaclass storage more than once");
+        MY_CXT.metas = metas;
+        SvREFCNT_inc_simple_void_NN(metas);
+    }
+}
+
+bool
+is_valid_class_name(SV* sv)
+CODE:
+{
+    SvGETMAGIC(sv);
+    if(SvPOKp(sv) && SvCUR(sv) > 0){
+        UV i;
+        RETVAL = TRUE;
+        for(i = 0; i < SvCUR(sv); i++){
+            char const c = SvPVX(sv)[i];
+            if(!(isALNUM(c) || c == ':')){
+                RETVAL = FALSE;
+                break;
+            }
+        }
+    }
+    else{
+        RETVAL = SvNIOKp(sv) ? TRUE : FALSE;
+    }
+}
+OUTPUT:
+    RETVAL
+
 bool
 is_class_loaded(SV* sv)
 
@@ -302,12 +415,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){
@@ -326,29 +435,62 @@ OUTPUT:
     RETVAL
 
 void
-generate_isa_predicate_for(SV* klass, SV* predicate_name = NULL)
+generate_isa_predicate_for(SV* arg, SV* predicate_name = NULL)
+ALIAS:
+    generate_isa_predicate_for = 0
+    generate_can_predicate_for = 1
 PPCODE:
 {
     const char* name_pv = NULL;
     CV* xsub;
 
-    SvGETMAGIC(klass);
-
-    if(!SvOK(klass)){
-        croak("You must define a class name");
-    }
+    must_defined(arg, ix == 0 ? "a class_name" : "method names");
 
     if(predicate_name){
-        SvGETMAGIC(predicate_name);
-        if(!SvOK(predicate_name)){
-            croak("You must define a predicate_name");
-        }
+        must_defined(predicate_name, "a predicate name");
         name_pv = SvPV_nolen_const(predicate_name);
     }
 
-    xsub = mouse_generate_isa_predicate_for(aTHX_ klass, name_pv);
+    if(ix == 0){
+        xsub = mouse_generate_isa_predicate_for(aTHX_ arg, name_pv);
+    }
+    else{
+        xsub = mouse_generate_can_predicate_for(aTHX_ arg, name_pv);
+    }
 
     if(predicate_name == NULL){ /* anonymous predicate */
-        XPUSHs( newRV_noinc((SV*)xsub) );
+        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);
     }
 }