root/lang/perl/arguments/trunk/arguments.xs @ 14595

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

/* base xs code from PadWalker.xs */
I32
_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 starting_block)
{
    dTHR;
    I32 i;
    PERL_CONTEXT *cx;
    for (i = starting_block; i >= 0; i--) {
        cx = &cxstk[i];
        switch (CxTYPE(cx)) {
        default:
            continue;
        case CXt_SUB:
#ifdef CXt_FORMAT /* In Perl 5.005, formats just used CXt_SUB */
        case CXt_FORMAT:
#endif
            return i;
        }
    }
    return i;
}

PERL_CONTEXT*
_upcontext(pTHX_ I32 count) 
{
    PERL_SI *top_si = PL_curstackinfo;
    I32 cxix = _dopoptosub_at(aTHX_ cxstack, cxstack_ix);
    PERL_CONTEXT *ccstack = cxstack;

    for (;;) {
        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 *) NULL;
        }
        if (PL_DBsub && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
            count++;
        if (!count--)
            break;

        cxix = _dopoptosub_at(aTHX_ ccstack, cxix - 1);
    }
    return &ccstack[cxix];
}

/* base xs code from Devel-Caller/Caller.xs */

MODULE = arguments              PACKAGE = arguments
PROTOTYPES: DISABLE

void
upcontext(uplevel)
I32 uplevel
  PPCODE:
    PERL_CONTEXT *cx = _upcontext(aTHX_ uplevel);
    if (!cx) {
        ST(0) = sv_2mortal(newRV( (SV *) NULL) );
    } else {
        if (cx->cx_type != CXt_SUB)
            croak("cx_type is %d not CXt_SUB\n", cx->cx_type);
        if (!cx->blk_sub.cv)
            croak("Context has no CV!\n");
        ST(0) = (SV*) newRV_inc( (SV*) cx->blk_sub.cv );
    }
    XSRETURN(1);