[Jifty-commit] r5342 - B

Jifty commits jifty-commit at lists.jifty.org
Tue Apr 29 15:53:05 EDT 2008


Author: clkao
Date: Tue Apr 29 15:52:53 2008
New Revision: 5342

Modified:
   B/B.xs

Log:
various helpers extracted from Want.xs to provide parent_op
which returns the current caller's entersub op entry.

This might want to be in a different module, but I can't get
the typemaps right that returns proper B::OP objects.


Modified: B/B.xs
==============================================================================
--- B/B.xs	(original)
+++ B/B.xs	Tue Apr 29 15:52:53 2008
@@ -98,8 +98,102 @@
 START_MY_CXT
 
 #define walkoptree_debug	(MY_CXT.x_walkoptree_debug)
+
 #define specialsv_list		(MY_CXT.x_specialsv_list)
 
+#define TOO_FAR \
+  croak("want: Called from outside a subroutine")
+
+
+
+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_EVAL:*/
+        case CXt_SUB:
+        case CXt_FORMAT:
+            DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
+            return i;
+        }
+    }
+    return i;
+}
+
+I32
+dopoptosub(pTHX_ I32 startingblock)
+{
+    dTHR;
+    return dopoptosub_at(aTHX_ cxstack, startingblock);
+}
+
+
+
+PERL_CONTEXT*
+upcontext(pTHX_ I32 count)
+{
+    PERL_SI *top_si = PL_curstackinfo;
+    I32 cxix = dopoptosub(aTHX_ cxstack_ix);
+    PERL_CONTEXT *cx;
+    PERL_CONTEXT *ccstack = cxstack;
+    I32 dbcxix;
+
+    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 < 0) {
+            return (PERL_CONTEXT *)0;
+        }
+        if (PL_DBsub && cxix >= 0 &&
+                ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
+            count++;
+        if (!count--)
+            break;
+        cxix = dopoptosub_at(aTHX_ ccstack, cxix - 1);
+    }
+    cx = &ccstack[cxix];
+    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+        dbcxix = dopoptosub_at(aTHX_ ccstack, cxix - 1);
+        /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
+           field below is defined for any cx. */
+        if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
+            cx = &ccstack[dbcxix];
+        }
+    }
+    return cx;
+}
+
+#define HAS_RETSTACK (\
+  PERL_REVISION < 5 || \
+  (PERL_REVISION == 5 && PERL_VERSION < 9) || \
+  (PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION < 2) \
+)
+
+OP*
+find_return_op(pTHX_ I32 uplevel)
+{
+    PERL_CONTEXT *cx = upcontext(aTHX_ uplevel);
+    if (!cx) TOO_FAR;
+    return (OP*) cx->blk_oldcop;
+
+#if HAS_RETSTACK
+    return PL_retstack[cx->blk_oldretsp - 1];
+#else
+    return cx->blk_sub.retop;
+#endif
+}
+
 static opclass
 cc_opclass(pTHX_ const OP *o)
 {
@@ -745,6 +839,13 @@
 
 MODULE = B	PACKAGE = B::OP		PREFIX = OP_
 
+B::OP
+OP_parent_op(I32 uplevel)
+  CODE:
+    RETVAL = find_return_op(aTHX_ uplevel);
+  OUTPUT:
+    RETVAL
+
 size_t
 OP_size(o)
 	B::OP		o


More information about the Jifty-commit mailing list