Make add_method update %DB::sub for profilers

[gitmo/Mouse.git] / xs-src / Mouse.xs

diff --git a/xs-src/Mouse.xs b/xs-src/Mouse.xs
index 0a7d3f9..34ba351 100644 (file)
--- a/xs-src/Mouse.xs
+++ b/xs-src/Mouse.xs
@@ -1,12 +1,14 @@
 #define  NEED_newSVpvn_flags_GLOBAL
 #include "mouse.h"
 
+/* keywords for methods/keys */
 SV* mouse_package;
 SV* mouse_namespace;
 SV* mouse_methods;
 SV* mouse_name;
 SV* mouse_get_attribute;
 SV* mouse_get_attribute_list;
+SV* mouse_coerce;
 
 #define MOUSE_xc_flags(a)       SvUVX(MOUSE_av_at((a), MOUSE_XC_FLAGS))
 #define MOUSE_xc_gen(a)         MOUSE_av_at((a), MOUSE_XC_GEN)
@@ -366,6 +368,7 @@ BOOT:
     mouse_namespace = newSVpvs_share("namespace");
     mouse_methods   = newSVpvs_share("methods");
     mouse_name      = newSVpvs_share("name");
+    mouse_coerce    = newSVpvs_share("coerce");
 
     mouse_get_attribute      = newSVpvs_share("get_attribute");
     mouse_get_attribute_list = newSVpvs_share("get_attribute_list");
@@ -446,6 +449,24 @@ CODE:
         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);