[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