Implement install_subroutines in XS

diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index b24cc31..98dd137 100644 (file)
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -60,6 +60,7 @@ BEGIN{
 
         (my $hack_mouse_file = __FILE__) =~ s/.Util//; # .../Mouse/Util.pm -> .../Mouse.pm
         $xs = eval sprintf("#line %d %s\n", __LINE__, $hack_mouse_file) . q{
+            local $^W = 0; # work around 'redefine' warning to &install_subroutines
             require XSLoader;
             XSLoader::load('Mouse', $VERSION);
             Mouse::Util->import({ into => 'Mouse::Meta::Method::Constructor::XS' }, ':meta');

diff --git a/mouse.h b/mouse.h
index 01518fd..e58d8ae 100644 (file)
--- a/mouse.h
+++ b/mouse.h
@@ -101,6 +101,7 @@ GV* mouse_stash_fetch(pTHX_ HV* const stash, const char* const name, I32 const n
 #define stash_fetch(s, n, l, c) mouse_stash_fetch(aTHX_ (s), (n), (l), (c))
 #define stash_fetchs(s, n, c)   mouse_stash_fetch(aTHX_ (s), STR_WITH_LEN(n), (c))
 
+void mouse_install_sub(pTHX_ GV* const gv, SV* const code_ref);
 
 #define MOUSEf_DIE_ON_FAIL 0x01
 MAGIC* mouse_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags);

diff --git a/xs-src/Mouse.xs b/xs-src/Mouse.xs
index 1759d04..f435464 100644 (file)
--- a/xs-src/Mouse.xs
+++ b/xs-src/Mouse.xs
@@ -535,42 +535,8 @@ CODE:
 
     /*  *{$package . '::' . $name} -> *gv */
     gv = gv_fetchpv(form("%"SVf"::%"SVf, package, name), GV_ADDMULTI, SVt_PVCV);
-    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 */
-
+    mouse_install_sub(aTHX_ gv, code_ref);
     (void)set_slot(methods, name, code); /* $self->{methods}{$name} = $code */
-
-    /* name the CODE ref if it's anonymous */
-    {
-        CV* const code_entity = (CV*)SvRV(code_ref);
-        if(CvANON(code_entity)
-            && CvGV(code_entity) /* 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(code_entity), 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(code_entity) = gv;
-            CvANON_off(code_entity);
-        }
-    }
 }
 
 MODULE = Mouse  PACKAGE = Mouse::Meta::Class

diff --git a/xs-src/MouseUtil.xs b/xs-src/MouseUtil.xs
index 92fa676..aba91be 100644 (file)
--- a/xs-src/MouseUtil.xs
+++ b/xs-src/MouseUtil.xs
@@ -259,6 +259,49 @@ 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
@@ -348,10 +391,10 @@ CODE:
     GV* gv;
 
     if(!SvOK(package)){
-        croak("You must define a package name");
+        croak("You must define %s", "a package name");
     }
     if(!SvOK(name)){
-        croak("You must define a subroutine name");
+        croak("You must define %s", "a subroutine name");
     }
 
     stash = gv_stashsv(package, FALSE);
@@ -405,3 +448,44 @@ PPCODE:
         mXPUSHs( newRV_inc((SV*)xsub) );
     }
 }
+
+# This xsub will redefine &Mouse::Util::install_subroutines()
+void
+install_subroutines(SV* into, ...)
+CODE:
+{
+    HV* stash;
+    I32 i;
+
+    SvGETMAGIC(into);
+    if(!SvOK(into)){
+        croak("You must define %s", "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;
+
+        SvGETMAGIC(name);
+        if(!SvOK(name)){
+            croak("You must define %s", "a subroutine name");
+        }
+        SvGETMAGIC(code);
+        if(!IsCodeRef(code)){
+            croak("You must define %s", "a CODE reference");
+        }
+
+        pv = SvPV_const(name, len);
+        gv = stash_fetch(stash, pv, len, TRUE);
+
+        mouse_install_sub(aTHX_ gv, code);
+    }
+}