Scope-Upper

 view release on metacpan or  search on metacpan

Upper.xs  view on Meta::CPAN

 newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
 newXSproto("Scope::Upper::yield",  XS_Scope__Upper_yield,  file, NULL);
 newXSproto("Scope::Upper::leave",  XS_Scope__Upper_leave,  file, NULL);
}

#if XSH_THREADSAFE

void
CLONE(...)
PROTOTYPE: DISABLE
PPCODE:
 xsh_clone();
 XSRETURN(0);

#endif /* XSH_THREADSAFE */

void
HERE()
PROTOTYPE:
PREINIT:
 I32 cxix;
PPCODE:
 cxix = su_context_real2logical(su_context_here());
 EXTEND(SP, 1);
 mPUSHi(cxix);
 XSRETURN(1);

void
UP(...)
PROTOTYPE: ;$
PREINIT:
 I32 cxix;
PPCODE:
 SU_GET_CONTEXT(0, 0, su_context_here());
 if (cxix > 0) {
  --cxix;
  cxix = su_context_skip_db(cxix);
  cxix = su_context_normalize_up(cxix);
  cxix = su_context_real2logical(cxix);
 } else {
  warn(su_stack_smash);
 }
 EXTEND(SP, 1);
 mPUSHi(cxix);
 XSRETURN(1);

void
SUB(...)
PROTOTYPE: ;$
PREINIT:
 I32 cxix;
PPCODE:
 SU_GET_CONTEXT(0, 0, cxstack_ix);
 EXTEND(SP, 1);
 for (; cxix >= 0; --cxix) {
  PERL_CONTEXT *cx = cxstack + cxix;
  switch (CxTYPE(cx)) {
   default:
    continue;
   case CXt_SUB:
    if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
     continue;

Upper.xs  view on Meta::CPAN

  }
 }
 warn(su_no_such_target, "subroutine");
 XSRETURN_UNDEF;

void
EVAL(...)
PROTOTYPE: ;$
PREINIT:
 I32 cxix;
PPCODE:
 SU_GET_CONTEXT(0, 0, cxstack_ix);
 EXTEND(SP, 1);
 for (; cxix >= 0; --cxix) {
  PERL_CONTEXT *cx = cxstack + cxix;
  switch (CxTYPE(cx)) {
   default:
    continue;
   case CXt_EVAL:
    cxix = su_context_real2logical(cxix);
    mPUSHi(cxix);

Upper.xs  view on Meta::CPAN

  }
 }
 warn(su_no_such_target, "eval");
 XSRETURN_UNDEF;

void
SCOPE(...)
PROTOTYPE: ;$
PREINIT:
 I32 cxix, level;
PPCODE:
 SU_GET_LEVEL(0, 0);
 cxix = su_context_here();
 while (--level >= 0) {
  if (cxix <= 0) {
   warn(su_stack_smash);
   break;
  }
  --cxix;
  cxix = su_context_skip_db(cxix);
  cxix = su_context_normalize_up(cxix);

Upper.xs  view on Meta::CPAN

 }
 EXTEND(SP, 1);
 mPUSHi(cxix);
 XSRETURN(1);

void
CALLER(...)
PROTOTYPE: ;$
PREINIT:
 I32 cxix, level;
PPCODE:
 SU_GET_LEVEL(0, 0);
 for (cxix = cxstack_ix; cxix > 0; --cxix) {
  PERL_CONTEXT *cx = cxstack + cxix;
  switch (CxTYPE(cx)) {
   case CXt_SUB:
    if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
     continue;
   case CXt_EVAL:
   case CXt_FORMAT:
    if (--level < 0)

Upper.xs  view on Meta::CPAN

 EXTEND(SP, 1);
 cxix = su_context_real2logical(cxix);
 mPUSHi(cxix);
 XSRETURN(1);

void
want_at(...)
PROTOTYPE: ;$
PREINIT:
 I32 cxix;
PPCODE:
 SU_GET_CONTEXT(0, 0, cxstack_ix);
 EXTEND(SP, 1);
 while (cxix > 0) {
  PERL_CONTEXT *cx = cxstack + cxix--;
  switch (CxTYPE(cx)) {
   case CXt_SUB:
    if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
     continue;
   case CXt_EVAL:
   case CXt_FORMAT: {

Upper.xs  view on Meta::CPAN

 }
 XSRETURN_UNDEF;

void
context_info(...)
PROTOTYPE: ;$
PREINIT:
 I32 cxix;
 const PERL_CONTEXT *cx, *dbcx;
 COP *cop;
PPCODE:
 SU_GET_CONTEXT(0, 0, su_context_skip_db(cxstack_ix));
 cxix = su_context_normalize_up(cxix);
 cx   = cxstack + cxix;
 dbcx = cx;
 if (PL_DBsub && cxix && (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)) {
  I32 i = su_context_skip_db(cxix - 1) + 1;
  if (i < cxix && CxTYPE(cxstack + i) == CXt_SUB)
   cx = cxstack + i;
 }
 cop  = cx->blk_oldcop;

Upper.xs  view on Meta::CPAN

 Newx(ud, 1, su_ud_localize);
 SU_UD_TYPE(ud) = SU_UD_TYPE_LOCALIZE;
 size = su_ud_localize_init(ud, sv, NULL, elem);
 su_init(ud, cxix, size);

void
uplevel(SV *code, ...)
PROTOTYPE: &@
PREINIT:
 I32 cxix, ret, args = 0;
PPCODE:
 if (SvROK(code))
  code = SvRV(code);
 if (SvTYPE(code) < SVt_PVCV)
  croak("First argument to uplevel must be a code reference");
 SU_GET_CONTEXT(1, items - 1, cxstack_ix);
 do {
  PERL_CONTEXT *cx = cxstack + cxix;
  switch (CxTYPE(cx)) {
   case CXt_EVAL:
    croak("Can't uplevel to an eval frame");

Upper.xs  view on Meta::CPAN

  }
 } while (--cxix >= 0);
 croak("Can't uplevel outside a subroutine");

void
uid(...)
PROTOTYPE: ;$
PREINIT:
 I32 cxix;
 SV *uid;
PPCODE:
 SU_GET_CONTEXT(0, 0, su_context_here());
 uid = su_uid_get(cxix);
 EXTEND(SP, 1);
 PUSHs(uid);
 XSRETURN(1);

void
validate_uid(SV *uid)
PROTOTYPE: $
PREINIT:
 SV *ret;
PPCODE:
 ret = su_uid_validate(uid) ? &PL_sv_yes : &PL_sv_no;
 EXTEND(SP, 1);
 PUSHs(ret);
 XSRETURN(1);