reimplement the %DB::sub functionality

4 files changed, 119 insertions, 20 deletions

diff --git a/.gitignore b/.gitignore
index 92100a6..b168bbb 100644
--- a/.gitignore
+++ b/.gitignore
@@ -12,4 +12,5 @@ MANIFEST.bak
 Package-Stash-*
 *.bs
 *.c
+!stolen_bits_of_padwalker.c
 *.o
diff --git a/Stash.xs b/Stash.xs
index 44e7ce4..e1d66e1 100644
--- a/Stash.xs
+++ b/Stash.xs
@@ -80,6 +80,12 @@
     GvIOp(g) = (IO*)(v);                \
 } while (0)
 
+/* XXX: the core implementation of caller() is private, so we need a
+ * a reimplementation. luckily, padwalker already has done this. rafl says
+ * that there should be a public interface in 5.14, so maybe look into
+ * converting to use that at some point */
+#include "stolen_bits_of_padwalker.c"
+
 typedef enum {
     VAR_NONE = 0,
     VAR_SCALAR,
@@ -416,24 +422,13 @@ add_symbol(self, variable, initial=NULL, ...)
     sv_catpvs(name, "::");
     sv_catpv(name, variable.name);
 
-    /* XXX: come back to this when i feel like reimplementing caller() */
-/*
-    my $filename = $opts{filename};
-    my $first_line_num = $opts{first_line_num};
-
-    (undef, $filename, $first_line_num) = caller
-        if not defined $filename;
-
-    my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
-
-    # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
-    $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
-*/
-/*
     if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
         int i;
-        char *filename = NULL, *name;
-        I32 first_line_num, last_line_num;
+        char *filename = NULL, *namepv;
+        I32 first_line_num = -1, last_line_num = -1;
+        STRLEN namelen;
+        SV *dbval;
+        HV *dbsub;
 
         if ((items - 3) % 2)
             croak("add_symbol: Odd number of elements in %%opts");
@@ -458,10 +453,33 @@ add_symbol(self, variable, initial=NULL, ...)
             }
         }
 
-        if (!filename) {
+        if (!filename || first_line_num == -1) {
+            I32 cxix_from, cxix_to;
+            PERL_CONTEXT *cx, *ccstack;
+            COP *cop = NULL;
+
+            cx = upcontext(0, &cop, &ccstack, &cxix_from, &cxix_to);
+            if (!cop)
+                cop = PL_curcop;
+
+            if (!filename)
+                filename = CopFILE(cop);
+            if (first_line_num == -1)
+                first_line_num = cop->cop_line;
+        }
+
+        if (last_line_num == -1)
+            last_line_num = first_line_num;
+
+        /* http://perldoc.perl.org/perldebguts.html#Debugger-Internals */
+        dbsub = get_hv("DB::sub", 1);
+        dbval = newSVpvf("%s:%d-%d", filename, first_line_num, last_line_num);
+        namepv = SvPV(name, namelen);
+        if (!hv_store(dbsub, namepv, namelen, dbval, 0)) {
+            warn("Failed to update $DB::sub for subroutine %s", namepv);
+            SvREFCNT_dec(dbval);
         }
     }
-*/
 
     /* GV_ADDMULTI rather than GV_ADD because otherwise you get 'used only
      * once' warnings in some situations... i can't reproduce this, but CMOP
diff --git a/stolen_bits_of_padwalker.c b/stolen_bits_of_padwalker.c
new file mode 100644
index 0000000..0f8d2ea
--- /dev/null
+++ b/stolen_bits_of_padwalker.c
@@ -0,0 +1,82 @@
+/* For development testing */
+#ifdef PACKAGE_STASH_DEBUGGING
+# define debug_print(x) printf x
+#else
+# define debug_print(x)
+#endif
+
+/* Originally stolen from pp_ctl.c; now significantly different */
+
+I32
+dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
+{
+    dTHR;
+    I32 i;
+    PERL_CONTEXT *cx;
+    for (i = startingblock; i >= 0; i--) {
+        cx = &cxstk[i];
+        switch (CxTYPE(cx)) {
+        default:
+            continue;
+        case CXt_SUB:
+        /* In Perl 5.005, formats just used CXt_SUB */
+#ifdef CXt_FORMAT
+       case CXt_FORMAT:
+#endif
+            debug_print(("**dopoptosub_at: found sub #%ld\n", (long)i));
+            return i;
+        }
+    }
+        debug_print(("**dopoptosub_at: not found #%ld\n", (long)i));
+    return i;
+}
+
+I32
+dopoptosub(pTHX_ I32 startingblock)
+{
+    dTHR;
+    return dopoptosub_at(aTHX_ cxstack, startingblock);
+}
+
+/* This function is based on the code of pp_caller */
+PERL_CONTEXT*
+upcontext(pTHX_ I32 count, COP **cop_p, PERL_CONTEXT **ccstack_p,
+                                I32 *cxix_from_p, I32 *cxix_to_p)
+{
+    PERL_SI *top_si = PL_curstackinfo;
+    I32 cxix = dopoptosub(aTHX_ cxstack_ix);
+    PERL_CONTEXT *ccstack = cxstack;
+
+    if (cxix_from_p) *cxix_from_p = cxstack_ix+1;
+    if (cxix_to_p)   *cxix_to_p   = cxix;
+    for (;;) {
+        /* we may be in a higher stacklevel, so dig down deeper */
+        while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
+            top_si  = top_si->si_prev;
+            ccstack = top_si->si_cxstack;
+            cxix = dopoptosub_at(aTHX_ ccstack, top_si->si_cxix);
+                        if (cxix_to_p && cxix_from_p) *cxix_from_p = *cxix_to_p;
+                        if (cxix_to_p) *cxix_to_p = cxix;
+        }
+        if (cxix < 0 && count == 0) {
+                    if (ccstack_p) *ccstack_p = ccstack;
+            return (PERL_CONTEXT *)0;
+                }
+        else if (cxix < 0)
+            return (PERL_CONTEXT *)-1;
+        if (PL_DBsub && cxix >= 0 &&
+                ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
+            count++;
+        if (!count--)
+            break;
+
+        if (cop_p) *cop_p = ccstack[cxix].blk_oldcop;
+        cxix = dopoptosub_at(aTHX_ ccstack, cxix - 1);
+                        if (cxix_to_p && cxix_from_p) *cxix_from_p = *cxix_to_p;
+                        if (cxix_to_p) *cxix_to_p = cxix;
+    }
+    if (ccstack_p) *ccstack_p = ccstack;
+    return &ccstack[cxix];
+}
+
+/* end thievery */
diff --git a/t/06-addsub.t b/t/06-addsub.t
index 50a67fd..1965afd 100644
--- a/t/06-addsub.t
+++ b/t/06-addsub.t
@@ -29,7 +29,6 @@ ok(defined($Foo::{funk}), '... the &funk slot was created successfully');
 is((Foo->funk())[0], 'Foo::funk', '... got the right value from the function');
 
 my $line = (Foo->funk())[1];
-{ local $TODO = "need to reimplement the db stuff in xs";
 is $DB::sub{'Foo::funk'}, sprintf "%s:%d-%d", __FILE__, $line, $line,
     '... got the right %DB::sub value for funk default args';
 
@@ -42,6 +41,5 @@ $foo_stash->add_symbol(
 
 is $DB::sub{'Foo::dunk'}, sprintf "%s:%d-%d", "FileName", 100, 199,
     '... got the right %DB::sub value for dunk with specified args';
-}
 
 done_testing;