stolen_bits_of_padwalker.c

   1 /* For development testing */
   2 #ifdef PACKAGE_STASH_DEBUGGING
   3 # define debug_print(x) printf x
   4 #else
   5 # define debug_print(x)
   6 #endif
   7
   8 /* Originally stolen from pp_ctl.c; now significantly different */
   9
  10 I32
  11 dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
  12 {
  13     dTHR;
  14     I32 i;
  15     PERL_CONTEXT *cx;
  16     for (i = startingblock; i >= 0; i--) {
  17         cx = &cxstk[i];
  18         switch (CxTYPE(cx)) {
  19         default:
  20             continue;
  21         case CXt_SUB:
  22         /* In Perl 5.005, formats just used CXt_SUB */
  23 #ifdef CXt_FORMAT
  24        case CXt_FORMAT:
  25 #endif
  26             debug_print(("**dopoptosub_at: found sub #%ld\n", (long)i));
  27             return i;
  28         }
  29     }
  30         debug_print(("**dopoptosub_at: not found #%ld\n", (long)i));
  31     return i;
  32 }
  33
  34 I32
  35 dopoptosub(pTHX_ I32 startingblock)
  36 {
  37     dTHR;
  38     return dopoptosub_at(aTHX_ cxstack, startingblock);
  39 }
  40
  41 /* This function is based on the code of pp_caller */
  42 PERL_CONTEXT*
  43 upcontext(pTHX_ I32 count, COP **cop_p, PERL_CONTEXT **ccstack_p,
  44                                 I32 *cxix_from_p, I32 *cxix_to_p)
  45 {
  46     PERL_SI *top_si = PL_curstackinfo;
  47     I32 cxix = dopoptosub(aTHX_ cxstack_ix);
  48     PERL_CONTEXT *ccstack = cxstack;
  49
  50     if (cxix_from_p) *cxix_from_p = cxstack_ix+1;
  51     if (cxix_to_p)   *cxix_to_p   = cxix;
  52     for (;;) {
  53         /* we may be in a higher stacklevel, so dig down deeper */
  54         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
  55             top_si  = top_si->si_prev;
  56             ccstack = top_si->si_cxstack;
  57             cxix = dopoptosub_at(aTHX_ ccstack, top_si->si_cxix);
  58                         if (cxix_to_p && cxix_from_p) *cxix_from_p = *cxix_to_p;
  59                         if (cxix_to_p) *cxix_to_p = cxix;
  60         }
  61         if (cxix < 0 && count == 0) {
  62                     if (ccstack_p) *ccstack_p = ccstack;
  63             return (PERL_CONTEXT *)0;
  64                 }
  65         else if (cxix < 0)
  66             return (PERL_CONTEXT *)-1;
  67         if (PL_DBsub && cxix >= 0 &&
  68                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
  69             count++;
  70         if (!count--)
  71             break;
  72
  73         if (cop_p) *cop_p = ccstack[cxix].blk_oldcop;
  74         cxix = dopoptosub_at(aTHX_ ccstack, cxix - 1);
  75                         if (cxix_to_p && cxix_from_p) *cxix_from_p = *cxix_to_p;
  76                         if (cxix_to_p) *cxix_to_p = cxix;
  77     }
  78     if (ccstack_p) *ccstack_p = ccstack;
  79     return &ccstack[cxix];
  80 }
  81
  82 /* end thievery */