#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "BUtils.h"

/* Stolen from pp_ctl.c (with modifications) */

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;
}


/* The most popular error message */
#define TOO_FAR \
  croak("want: Called from outside a subroutine")

/* Between 5.9.1 and 5.9.2 the retstack was removed, and the
   return op is now stored on the cxstack. */
#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;
#if HAS_RETSTACK
    return PL_retstack[cx->blk_oldretsp - 1];
#else
    return cx->blk_sub.retop;
#endif
}

OP*
find_oldcop(pTHX_ I32 uplevel)
{
    PERL_CONTEXT *cx = upcontext(aTHX_ uplevel);
    if (!cx) TOO_FAR;
    return (OP*) cx->blk_oldcop;
}


MODULE = B::OP::Util           PACKAGE = B::OP::Util          PREFIX = OP_Util_
PROTOTYPES: DISABLE

B::OP
parent_op(I32 uplevel)
  CODE:
    RETVAL = find_oldcop(aTHX_ uplevel);
  OUTPUT:
    RETVAL

B::OP
return_op(I32 uplevel)
  CODE:
    RETVAL = find_return_op(aTHX_ uplevel);
  OUTPUT:
    RETVAL

#define PERL_CORE
#include "embed.h"

#define newSV_type(a)           Perl_newSV_type(aTHX_ a)

B::CV
CvNEW_with_start(cv, root, start)
       B::CV   cv
       B::OP   root
       B::OP   start
    PREINIT:
       CV *new;
    CODE:
       new = cv_clone(cv);
       CvROOT(new) = root;
       CvSTART(new) = start;
       CvDEPTH(new) = 0;
       SvREFCNT_inc(new);
       RETVAL = new;
    OUTPUT:
       RETVAL

#undef PERL_CORE