view release on metacpan or  search on metacpan

Upper.xs  view on Meta::CPAN

 PERL_UNUSED_VAR(cv); /* -W */
 PERL_UNUSED_VAR(ax); /* -Wall */

 SU_GET_CONTEXT(0, items - 1, su_context_here());
 XSH_CXT.yield_storage.cxix   = cxix;
 XSH_CXT.yield_storage.items  = items;
 XSH_CXT.yield_storage.savesp = PL_stack_sp;
 if (items > 0) {
  XSH_CXT.yield_storage.items--;
  XSH_CXT.yield_storage.savesp--;
 }
 /* See XS_Scope__Upper_unwind */
 if (GIMME_V == G_SCALAR)
  PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
 SAVEDESTRUCTOR_X(su_yield, su_yield_name);
 return;
}

static const char su_leave_name[] = "leave";

XS(XS_Scope__Upper_leave) {
#ifdef dVAR
 dVAR; dXSARGS;
#else
 dXSARGS;
#endif
 dXSH_CXT;

 PERL_UNUSED_VAR(cv); /* -W */
 PERL_UNUSED_VAR(ax); /* -Wall */

 XSH_CXT.yield_storage.cxix   = su_context_here();
 XSH_CXT.yield_storage.items  = items;
 XSH_CXT.yield_storage.savesp = PL_stack_sp;
 /* See XS_Scope__Upper_unwind */
 if (GIMME_V == G_SCALAR)
  PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;

 SAVEDESTRUCTOR_X(su_yield, su_leave_name);

 return;
}

MODULE = Scope::Upper            PACKAGE = Scope::Upper

PROTOTYPES: ENABLE

BOOT:
{
 xsh_setup();
 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;
    cxix = su_context_real2logical(cxix);
    mPUSHi(cxix);
    XSRETURN(1);
  }
 }
 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);
    XSRETURN(1);
  }
 }
 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);
  cxix = su_context_real2logical(cxix);
 }
 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)
     goto done;
    break;
  }
 }
done:
 if (level >= 0)
  warn(su_stack_smash);
 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: {
    I32 gimme = cx->blk_gimme;
    switch (gimme) {
     case G_VOID:   XSRETURN_UNDEF; break;
     case G_SCALAR: XSRETURN_NO;    break;
     case G_ARRAY:  XSRETURN_YES;   break;
    }
    break;
   }
  }
 }
 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;
 EXTEND(SP, SU_INFO_COUNT);
 /* stash (0) */
 {
  HV *stash = CopSTASH(cop);
  if (stash)
   PUSHs(su_newmortal_pvn(HvNAME(stash), HvNAMELEN(stash)));
  else
   PUSHs(&PL_sv_undef);
 }
 /* file (1) */
 PUSHs(su_newmortal_pvn(OutCopFILE(cop), OutCopFILE_len(cop)));
 /* line (2) */
 mPUSHi(CopLINE(cop));
 /* subroutine (3) and has_args (4) */
 switch (CxTYPE(cx)) {
  case CXt_SUB:
  case CXt_FORMAT: {
   GV *cvgv = CvGV(dbcx->blk_sub.cv);
   if (cvgv && isGV(cvgv)) {
    SV *sv = sv_newmortal();
    gv_efullname3(sv, cvgv, NULL);
    PUSHs(sv);
   } else {
    PUSHs(su_newmortal_pvs("(unknown)"));
   }
   if (CxHASARGS(cx))
    PUSHs(&PL_sv_yes);
   else
    PUSHs(&PL_sv_no);
   break;
  }
  case CXt_EVAL:
   PUSHs(su_newmortal_pvs("(eval)"));
   mPUSHi(0);
   break;
  default:
   PUSHs(&PL_sv_undef);
   PUSHs(&PL_sv_undef);
 }
 /* gimme (5) */
 switch (su_context_gimme(cxix)) {
  case G_ARRAY:
   PUSHs(&PL_sv_yes);
   break;
  case G_SCALAR:
   PUSHs(&PL_sv_no);
   break;
  default: /* G_VOID */
   PUSHs(&PL_sv_undef);
   break;

Upper.xs  view on Meta::CPAN

 su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);

void
localize(SV *sv, SV *val, ...)
PROTOTYPE: $$;$
PREINIT:
 I32 cxix;
 I32 size;
 su_ud_localize *ud;
CODE:
 SU_GET_CONTEXT(2, 2, su_context_skip_db(cxstack_ix));
 cxix = su_context_normalize_down(cxix);
 Newx(ud, 1, su_ud_localize);
 SU_UD_TYPE(ud) = SU_UD_TYPE_LOCALIZE;
 size = su_ud_localize_init(ud, sv, val, NULL);
 su_init(ud, cxix, size);

void
localize_elem(SV *sv, SV *elem, SV *val, ...)
PROTOTYPE: $$$;$
PREINIT:
 I32 cxix;
 I32 size;
 su_ud_localize *ud;
CODE:
 if (SvTYPE(sv) >= SVt_PVGV)
  croak("Can't infer the element localization type from a glob and the value");
 SU_GET_CONTEXT(3, 3, su_context_skip_db(cxstack_ix));
 cxix = su_context_normalize_down(cxix);
 Newx(ud, 1, su_ud_localize);
 /* Initialize SU_UD_ORIGIN(ud) in case SU_UD_LOCALIZE_FREE(ud) needs it */
 SU_UD_ORIGIN(ud) = NULL;
 SU_UD_TYPE(ud)   = SU_UD_TYPE_LOCALIZE;
 size = su_ud_localize_init(ud, sv, val, elem);
 if (SU_UD_PRIVATE(ud) != SVt_PVAV && SU_UD_PRIVATE(ud) != SVt_PVHV) {
  SU_UD_LOCALIZE_FREE(ud);
  croak("Can't localize an element of something that isn't an array or a hash");
 }
 su_init(ud, cxix, size);

void
localize_delete(SV *sv, SV *elem, ...)
PROTOTYPE: $$;$
PREINIT:
 I32 cxix;
 I32 size;
 su_ud_localize *ud;
CODE:
 SU_GET_CONTEXT(2, 2, su_context_skip_db(cxstack_ix));
 cxix = su_context_normalize_down(cxix);
 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");
   case CXt_FORMAT:
    croak("Can't uplevel to a format frame");
   case CXt_SUB:
    if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
     continue;
    if (items > 1) {
     PL_stack_sp--;
     args = items - 2;
    }
    /* su_uplevel() takes care of extending the stack if needed. */
#if SU_HAS_NEW_CXT
    ret = su_uplevel_new((CV *) code, cxix, args);
#else
    ret = su_uplevel_old((CV *) code, cxix, args);
#endif
    XSRETURN(ret);
   default:
    break;
  }
 } 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);