1 files changed, 82 insertions, 0 deletions
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 */