view release on metacpan or  search on metacpan

RunBlock.xs  view on Meta::CPAN

      PL_op, OP_NAME(PL_op), cxstack_ix, PL_op->op_next, PL_op->op_sibling);
  }
  fprintf(stderr, "(my_trace_runopts:leave#%d)\n", depth);
  --depth;
  TAINT_NOT;
  return 0;
}
#endif

/* ----------------------------------------------------------------------------
 * dopoptosub_at (pp_ctl.c).
 * ------------------------------------------------------------------------- */
STATIC I32
S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
{
  I32 i;
  for (i = startingblock; i >= 0; i--)
  {
    switch( CxTYPE(&cxstk[i]) )
    {
      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;
}

/* ----------------------------------------------------------------------------
 * XS codes.
 * ------------------------------------------------------------------------- */

MODULE = Devel::RunBlock    PACKAGE = Devel::RunBlock    

int
_runblock(coderef)
    SV* coderef;
  CODE:
    {
      run_info->prev_op_is_return = 0;
      run_info->old_runops = PL_runops;
      PL_runops = &my_runops;
      call_sv(coderef, G_DISCARD);
      if( run_info->old_runops )
      {
        PL_runops = run_info->old_runops;
        run_info->old_runops = NULL;
      }
      RETVAL = run_info->prev_op_is_return;
    }
  OUTPUT:
    RETVAL

void
_long_wantarray(up)
    int up;
  PPCODE:
    {
      I32 cxix;
      for( cxix = cxstack_ix; up>=0; --up, --cxix )
      {
        cxix = S_dopoptosub_at(aTHX_ cxstack, cxix);
      }
      if (cxix < 0)
        XSRETURN_UNDEF;
      switch (cxstack[cxix].blk_gimme)
      {
      case G_ARRAY:  XSRETURN_YES;
      case G_SCALAR: XSRETURN_NO;
      default:       XSRETURN_UNDEF;
      }
    }

void
_long_return(up)
    int up;
  PPCODE:
    {
      I32 cxix;
      CV* cv_retops;
#if DEBUG_MESSAGES
      fprintf(stderr, "_long_return:enter(up=%d)\n", up)
      for( cxix=cxstack_ix; cxix>=0; --cxix )
      {
        switch( CxTYPE(&cxstack[cxix]) )
        {
        case CXt_NULL:   fprintf(stderr, "  #%d %s\n", cxix, "null"); break;
        case CXt_SUB:    fprintf(stderr, "  #%d %s\n", cxix, "sub"); break;
        case CXt_EVAL:   fprintf(stderr, "  #%d %s\n", cxix, "eval"); break;
        case CXt_LOOP:   fprintf(stderr, "  #%d %s\n", cxix, "loop"); break;
        case CXt_SUBST:  fprintf(stderr, "  #%d %s\n", cxix, "subst"); break;
        case CXt_BLOCK:  fprintf(stderr, "  #%d %s\n", cxix, "block"); break;
        case CXt_FORMAT: fprintf(stderr, "  #%d %s\n", cxix, "format"); break;
        default:         fprintf(stderr, "  #%d %d\n", cxix, CxTYPE(&cxstack[cxix])); break;
        }
      }
#endif
      cxix = cxstack_ix;
      for( ; up>1; --up )
      {
        const PERL_CONTEXT* cx;
        CV* cv;
#if DEBUG_MESSAGES
        fprintf(stderr, "_long_return: up = %d cx <= %d\n", up, cxix);
#endif
        cxix = S_dopoptosub_at(aTHX_ cxstack, cxix);
#if DEBUG_MESSAGES
        fprintf(stderr, "_long_return: up = %d cx => %d\n", up, cxix);
#endif
        if( cxix < 0 )
        {
          croak("_long_return run out callstack");
        }
        cx = &cxstack[cxix];
        if( 0 && CxTYPE(cx)==CXt_EVAL )
        {
          ++up;
          --cxix;
          continue;
        }
        cv = cx->blk_sub.cv;
#if DEBUG_MESSAGES
        fprintf(stderr, "_long_return: up = %d type=%d, cv => %p\n", up, CxTYPE(cx), cv);
#endif
        if( CxTYPE(cx)==CXt_SUB && CvXSUB(cv) )
        {
          croak("_long_return could not through xsub");
        }
        if( up>0 )
        {
          --cxix;
        }
      }
#if DEBUG_MESSAGES
      fprintf(stderr, "_long_return:rewrite ix(%d..%d)..\n", cxix, cxstack_ix);
      fprintf(stderr, "_long_return:rewrite sp(%d..%d/%d)..\n", cxstack[cxix].blk_oldretsp, cxstack[cxstack_ix].blk_oldretsp,PL_retstack_ix);
#endif