+ gimme = GIMME_V;
+ /* Make PL_stack_sp point just before the CV. */
+ PL_stack_sp -= args + 1;
+ old_mark = AvFILLp(PL_curstack) = PL_stack_sp - PL_stack_base;
+ SPAGAIN;
+
+ sud = su_uplevel_storage_new(cxix);
+
+ sud->cxix = cxix;
+ sud->died = 1;
+ sud->callback = NULL;
+ sud->renamed = NULL;
+ SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
+
+ si = sud->si;
+
+ si->si_type = cur->si_type;
+ si->si_next = NULL;
+ si->si_prev = cur->si_prev;
+#ifdef DEBUGGING
+ si->si_markoff = cx->blk_oldmarksp;
+#endif
+
+ /* Allocate enough space for all the elements of the original stack up to the
+ * target context, plus the forthcoming arguments. */
+ new_mark = cx->blk_oldsp;
+ av_extend(si->si_stack, new_mark + 1 + args + 1);
+ Copy(PL_curstack, AvARRAY(si->si_stack), new_mark + 1, SV *);
+ AvFILLp(si->si_stack) = new_mark;
+ SU_POISON(AvARRAY(si->si_stack) + new_mark + 1, args + 1, SV *);
+
+ /* Specialized SWITCHSTACK() */
+ PL_stack_base = AvARRAY(si->si_stack);
+ old_stack_sp = PL_stack_sp;
+ PL_stack_sp = PL_stack_base + AvFILLp(si->si_stack);
+ PL_stack_max = PL_stack_base + AvMAX(si->si_stack);
+ SPAGAIN;
+
+ /* Copy the context stack up to the context just below the target. */
+ si->si_cxix = (cxix < 0) ? -1 : (cxix - 1);
+ if (si->si_cxmax < cxix) {
+ /* The max size must be at least two so that GROW(max) = (max*3)/2 > max */
+ si->si_cxmax = (cxix < 4) ? 4 : cxix;
+ Renew(si->si_cxstack, si->si_cxmax + 1, PERL_CONTEXT);
+ }
+ Copy(cur->si_cxstack, si->si_cxstack, cxix, PERL_CONTEXT);
+ SU_POISON(si->si_cxstack + cxix, si->si_cxmax + 1 - cxix, PERL_CONTEXT);
+
+ target = cx->blk_sub.cv;
+ sud->target = (CV *) SvREFCNT_inc(target);
+ sud->target_depth = CvDEPTH(target);
+
+ /* blk_oldcop is essentially needed for caller() and stack traces. It has no
+ * run-time implication, since PL_curcop will be overwritten as soon as we
+ * enter a sub (a sub starts by a nextstate/dbstate). Hence it's safe to just
+ * make it point to the blk_oldcop for the target frame, so that caller()
+ * reports the right file name, line number and lexical hints. */
+ SU_UPLEVEL_SAVE(curcop, cx->blk_oldcop);
+ /* Don't reset PL_markstack_ptr, or we would overwrite the mark stack below
+ * this point. Don't reset PL_curpm either, we want the most recent matches. */
+
+ SU_UPLEVEL_SAVE(curstackinfo, si);
+ /* If those two are equal, we need to fool POPSTACK_TO() */
+ if (PL_mainstack == PL_curstack)
+ SU_UPLEVEL_SAVE(mainstack, si->si_stack);
+ else
+ sud->old_mainstack = NULL;
+ PL_curstack = si->si_stack;
+
+ renamed = su_cv_clone(callback, CvGV(target));
+ sud->renamed = renamed;
+
+ PUSHMARK(SP);
+ /* Both SP and old_stack_sp point just before the CV. */
+ Copy(old_stack_sp + 2, SP + 1, args, SV *);
+ SP += args;
+ PUSHs((SV *) renamed);
+ PUTBACK;
+
+ Zero(&sub_op, 1, UNOP);
+ sub_op.op_type = OP_ENTERSUB;
+ sub_op.op_next = NULL;
+ sub_op.op_flags = OP_GIMME_REVERSE(gimme) | OPf_STACKED;
+ if (PL_DBsub)
+ sub_op.op_flags |= OPpENTERSUB_DB;
+
+ SU_UPLEVEL_SAVE(op, (OP *) &sub_op);
+
+#if SU_UPLEVEL_HIJACKS_RUNOPS
+ sud->old_runops = PL_runops;
+#endif
+
+ sud->old_catch = CATCH_GET;
+ CATCH_SET(TRUE);
+
+ if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) {
+ PERL_CONTEXT *sub_cx = cxstack + cxstack_ix;
+
+ /* If pp_entersub() returns a non-null OP, it means that the callback is not
+ * an XSUB. */
+
+ sud->callback = MUTABLE_CV(SvREFCNT_inc(callback));
+ CvDEPTH(callback)++;
+
+ if (CxHASARGS(cx) && cx->blk_sub.argarray) {
+ /* The call to pp_entersub() has saved the current @_ (in XS terms,
+ * GvAV(PL_defgv)) in the savearray member, and has created a new argarray
+ * with what we put on the stack. But we want to fake up the same arguments
+ * as the ones in use at the context we uplevel to, so we replace the
+ * argarray with an unreal copy of the original @_. */
+ AV *av = newAV();
+ AvREAL_off(av);
+ AvREIFY_on(av);
+ av_extend(av, AvMAX(cx->blk_sub.argarray));
+ AvFILLp(av) = AvFILLp(cx->blk_sub.argarray);
+ Copy(AvARRAY(cx->blk_sub.argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
+ sub_cx->blk_sub.argarray = av;
+ } else {
+ SvREFCNT_inc_simple_void(sub_cx->blk_sub.argarray);
+ }
+
+ if (su_uplevel_goto_static(CvROOT(renamed))) {
+#if SU_UPLEVEL_HIJACKS_RUNOPS
+ if (PL_runops != PL_runops_std) {
+ if (PL_runops == PL_runops_dbg) {
+ if (PL_debug)
+ croak("uplevel() can't execute code that calls goto when debugging flags are set");
+ } else if (PL_runops != su_uplevel_goto_runops)
+ croak("uplevel() can't execute code that calls goto with a custom runloop");
+ }
+
+ PL_runops = su_uplevel_goto_runops;
+#else /* SU_UPLEVEL_HIJACKS_RUNOPS */
+ croak("uplevel() can't execute code that calls goto before perl 5.8");
+#endif /* !SU_UPLEVEL_HIJACKS_RUNOPS */
+ }
+
+ CALLRUNOPS(aTHX);
+ }
+
+ sud->died = 0;
+
+ ret = PL_stack_sp - (PL_stack_base + new_mark);
+ if (ret > 0) {
+ AV *old_stack = sud->old_curstackinfo->si_stack;
+
+ if (old_mark + ret > AvMAX(old_stack)) {
+ /* Specialized EXTEND(old_sp, ret) */
+ av_extend(old_stack, old_mark + ret + 1);
+ old_stack_sp = AvARRAY(old_stack) + old_mark;
+ }
+
+ Copy(PL_stack_sp - ret + 1, old_stack_sp + 1, ret, SV *);
+ PL_stack_sp += ret;
+ AvFILLp(old_stack) += ret;
+ }
+
+ LEAVE;
+
+ return ret;
+}
+
+/* --- Unique context ID --------------------------------------------------- */
+
+static su_uid *su_uid_storage_fetch(pTHX_ UV depth) {
+#define su_uid_storage_fetch(D) su_uid_storage_fetch(aTHX_ (D))
+ su_uid *map;
+ STRLEN alloc;
+ dMY_CXT;
+
+ map = MY_CXT.uid_storage.map;
+ alloc = MY_CXT.uid_storage.alloc;
+
+ if (depth >= alloc) {
+ STRLEN i;
+
+ Renew(map, depth + 1, su_uid);
+ for (i = alloc; i <= depth; ++i) {
+ map[i].seq = 0;
+ map[i].flags = 0;
+ }
+
+ MY_CXT.uid_storage.map = map;
+ MY_CXT.uid_storage.alloc = depth + 1;
+ }
+
+ if (depth >= MY_CXT.uid_storage.used)
+ MY_CXT.uid_storage.used = depth + 1;
+
+ return map + depth;
+}
+
+static int su_uid_storage_check(pTHX_ UV depth, UV seq) {
+#define su_uid_storage_check(D, S) su_uid_storage_check(aTHX_ (D), (S))
+ su_uid *uid;
+ dMY_CXT;
+
+ if (depth >= MY_CXT.uid_storage.used)
+ return 0;
+
+ uid = MY_CXT.uid_storage.map + depth;
+
+ return (uid->seq == seq) && (uid->flags & SU_UID_ACTIVE);
+}
+
+static SV *su_uid_get(pTHX_ I32 cxix) {
+#define su_uid_get(I) su_uid_get(aTHX_ (I))
+ su_uid *uid;
+ SV *uid_sv;
+ UV depth;
+
+ depth = su_uid_depth(cxix);
+ uid = su_uid_storage_fetch(depth);
+
+ if (!(uid->flags & SU_UID_ACTIVE)) {
+ su_ud_uid *ud;
+
+ uid->seq = su_uid_seq_next(depth);
+ uid->flags |= SU_UID_ACTIVE;
+
+ Newx(ud, 1, su_ud_uid);
+ SU_UD_TYPE(ud) = SU_UD_TYPE_UID;
+ ud->idx = depth;
+ su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);
+ }
+
+ uid_sv = sv_newmortal();
+ sv_setpvf(uid_sv, "%"UVuf"-%"UVuf, depth, uid->seq);
+
+ return uid_sv;
+}
+
+#ifdef grok_number
+
+#define su_grok_number(S, L, VP) grok_number((S), (L), (VP))
+
+#else /* grok_number */
+
+#define IS_NUMBER_IN_UV 0x1
+
+static int su_grok_number(pTHX_ const char *s, STRLEN len, UV *valuep) {
+#define su_grok_number(S, L, VP) su_grok_number(aTHX_ (S), (L), (VP))
+ STRLEN i;
+ SV *tmpsv;
+
+ /* This crude check should be good enough for a fallback implementation.
+ * Better be too strict than too lax. */
+ for (i = 0; i < len; ++i) {
+ if (!isDIGIT(s[i]))
+ return 0;
+ }
+
+ tmpsv = sv_newmortal();
+ sv_setpvn(tmpsv, s, len);
+ *valuep = sv_2uv(tmpsv);
+
+ return IS_NUMBER_IN_UV;
+}
+
+#endif /* !grok_number */
+
+static int su_uid_validate(pTHX_ SV *uid) {
+#define su_uid_validate(U) su_uid_validate(aTHX_ (U))
+ const char *s;
+ STRLEN len, p = 0;
+ UV depth, seq;
+ int type;
+
+ s = SvPV_const(uid, len);
+
+ while (p < len && s[p] != '-')
+ ++p;
+ if (p >= len)
+ croak("UID contains only one part");
+
+ type = su_grok_number(s, p, &depth);
+ if (type != IS_NUMBER_IN_UV)
+ croak("First UID part is not an unsigned integer");
+
+ ++p; /* Skip '-'. As we used to have p < len, len - (p + 1) >= 0. */
+
+ type = su_grok_number(s + p, len - p, &seq);
+ if (type != IS_NUMBER_IN_UV)
+ croak("Second UID part is not an unsigned integer");
+
+ return su_uid_storage_check(depth, seq);
+}
+
+/* --- Context operations -------------------------------------------------- */
+
+/* Remove sequences of BLOCKs having DB for stash, followed by a SUB context
+ * for the debugger callback. */
+
+static I32 su_context_skip_db(pTHX_ I32 cxix) {
+#define su_context_skip_db(C) su_context_skip_db(aTHX_ (C))
+ I32 i;
+
+ if (!PL_DBsub)
+ return cxix;
+
+ for (i = cxix; i > 0; --i) {
+ PERL_CONTEXT *cx = cxstack + i;
+
+ switch (CxTYPE(cx)) {
+#if SU_HAS_PERL(5, 17, 1)
+ case CXt_LOOP_PLAIN:
+#endif
+ case CXt_BLOCK:
+ if (cx->blk_oldcop && CopSTASH(cx->blk_oldcop) == GvSTASH(PL_DBgv))
+ continue;
+ break;
+ case CXt_SUB:
+ if (cx->blk_sub.cv == GvCV(PL_DBsub)) {
+ cxix = i - 1;
+ continue;
+ }
+ break;
+ default:
+ break;
+ }
+
+ break;
+ }
+
+ return cxix;
+}
+
+
+static I32 su_context_normalize_up(pTHX_ I32 cxix) {
+#define su_context_normalize_up(C) su_context_normalize_up(aTHX_ (C))
+ PERL_CONTEXT *cx;
+
+ if (cxix <= 0)
+ return 0;
+
+ cx = cxstack + cxix;
+ if (CxTYPE(cx) == CXt_BLOCK) {
+ PERL_CONTEXT *prev = cx - 1;
+
+ switch (CxTYPE(prev)) {
+#if SU_HAS_PERL(5, 10, 0)
+ case CXt_GIVEN:
+ case CXt_WHEN:
+#endif
+#if SU_HAS_PERL(5, 11, 0)
+ /* That's the only subcategory that can cause an extra BLOCK context */
+ case CXt_LOOP_PLAIN:
+#else
+ case CXt_LOOP:
+#endif
+ if (cx->blk_oldcop == prev->blk_oldcop)
+ return cxix - 1;
+ break;
+ case CXt_SUBST:
+ if (cx->blk_oldcop && OpSIBLING(cx->blk_oldcop)
+ && OpSIBLING(cx->blk_oldcop)->op_type == OP_SUBST)
+ return cxix - 1;
+ break;
+ }
+ }
+
+ return cxix;
+}
+
+static I32 su_context_normalize_down(pTHX_ I32 cxix) {
+#define su_context_normalize_down(C) su_context_normalize_down(aTHX_ (C))
+ PERL_CONTEXT *next;
+
+ if (cxix >= cxstack_ix)
+ return cxstack_ix;
+
+ next = cxstack + cxix + 1;
+ if (CxTYPE(next) == CXt_BLOCK) {
+ PERL_CONTEXT *cx = next - 1;
+
+ switch (CxTYPE(cx)) {
+#if SU_HAS_PERL(5, 10, 0)
+ case CXt_GIVEN:
+ case CXt_WHEN:
+#endif
+#if SU_HAS_PERL(5, 11, 0)
+ /* That's the only subcategory that can cause an extra BLOCK context */
+ case CXt_LOOP_PLAIN:
+#else
+ case CXt_LOOP:
+#endif
+ if (cx->blk_oldcop == next->blk_oldcop)
+ return cxix + 1;
+ break;
+ case CXt_SUBST:
+ if (next->blk_oldcop && OpSIBLING(next->blk_oldcop)
+ && OpSIBLING(next->blk_oldcop)->op_type == OP_SUBST)
+ return cxix + 1;
+ break;
+ }
+ }
+
+ return cxix;
+}
+
+#define su_context_here() su_context_normalize_up(su_context_skip_db(cxstack_ix))
+
+static I32 su_context_gimme(pTHX_ I32 cxix) {
+#define su_context_gimme(C) su_context_gimme(aTHX_ (C))
+ I32 i;
+
+ for (i = cxix; i >= 0; --i) {
+ PERL_CONTEXT *cx = cxstack + i;
+
+ switch (CxTYPE(cx)) {
+ /* gimme is always G_ARRAY for loop contexts. */
+#if SU_HAS_PERL(5, 11, 0)
+ case CXt_LOOP_FOR:
+ case CXt_LOOP_PLAIN:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_LAZYIV:
+#else
+ case CXt_LOOP:
+#endif
+ case CXt_SUBST: {
+ const COP *cop = cx->blk_oldcop;
+ if (cop && OpSIBLING(cop)) {
+ switch (OpSIBLING(cop)->op_flags & OPf_WANT) {
+ case OPf_WANT_VOID:
+ return G_VOID;
+ case OPf_WANT_SCALAR:
+ return G_SCALAR;
+ case OPf_WANT_LIST:
+ return G_ARRAY;
+ default:
+ break;
+ }
+ }
+ break;
+ }
+ default:
+ return CxGIMME(cx);
+ break;
+ }
+ }
+
+ return G_VOID;
+}
+
+/* --- Global setup/teardown ----------------------------------------------- */
+
+static VOL U32 su_initialized = 0;
+
+static void su_global_teardown(pTHX_ void *root) {
+ if (!su_initialized)
+ return;
+
+#if SU_MULTIPLICITY
+ if (aTHX != root)
+ return;
+#endif
+
+ SU_LOCK(&su_uid_seq_counter_mutex);
+ PerlMemShared_free(su_uid_seq_counter.seqs);
+ su_uid_seq_counter.size = 0;
+ SU_UNLOCK(&su_uid_seq_counter_mutex);
+
+ MUTEX_DESTROY(&su_uid_seq_counter_mutex);
+
+ su_initialized = 0;
+
+ return;
+}
+
+XS(XS_Scope__Upper_unwind);
+XS(XS_Scope__Upper_yield);
+XS(XS_Scope__Upper_leave);
+
+#if SU_HAS_PERL(5, 9, 0)
+# define SU_XS_FILE_TYPE const char
+#else
+# define SU_XS_FILE_TYPE char
+#endif
+
+static void su_global_setup(pTHX_ SU_XS_FILE_TYPE *file) {
+#define su_global_setup(F) su_global_setup(aTHX_ (F))
+ HV *stash;
+
+ if (su_initialized)
+ return;
+
+ MUTEX_INIT(&su_uid_seq_counter_mutex);
+
+ SU_LOCK(&su_uid_seq_counter_mutex);
+ su_uid_seq_counter.seqs = NULL;
+ su_uid_seq_counter.size = 0;
+ SU_UNLOCK(&su_uid_seq_counter_mutex);
+
+ stash = gv_stashpv(__PACKAGE__, 1);
+ newCONSTSUB(stash, "TOP", newSViv(0));
+ newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE));
+
+ 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 SU_MULTIPLICITY
+ call_atexit(su_global_teardown, aTHX);
+#else
+ call_atexit(su_global_teardown, NULL);
+#endif
+
+ su_initialized = 1;
+
+ return;
+}
+
+/* --- Interpreter setup/teardown ------------------------------------------ */
+
+static void su_local_teardown(pTHX_ void *param) {
+ su_uplevel_ud *cur;
+ dMY_CXT;
+
+ Safefree(MY_CXT.uid_storage.map);
+
+ cur = MY_CXT.uplevel_storage.root;
+ if (cur) {
+ su_uplevel_ud *prev;
+ do {
+ prev = cur;
+ cur = prev->next;
+ su_uplevel_ud_delete(prev);
+ } while (cur);
+ }
+
+ return;
+}
+
+static void su_local_setup(pTHX) {
+#define su_local_setup() su_local_setup(aTHX)
+ MY_CXT_INIT;
+
+ MY_CXT.stack_placeholder = NULL;
+
+ /* NewOp() calls calloc() which just zeroes the memory with memset(). */
+ Zero(&(MY_CXT.unwind_storage.return_op), 1, LISTOP);
+ MY_CXT.unwind_storage.return_op.op_type = OP_RETURN;
+ MY_CXT.unwind_storage.return_op.op_ppaddr = PL_ppaddr[OP_RETURN];
+
+ Zero(&(MY_CXT.unwind_storage.proxy_op), 1, OP);
+ MY_CXT.unwind_storage.proxy_op.op_type = OP_STUB;
+ MY_CXT.unwind_storage.proxy_op.op_ppaddr = NULL;
+
+ Zero(&(MY_CXT.yield_storage.leave_op), 1, UNOP);
+ MY_CXT.yield_storage.leave_op.op_type = OP_STUB;
+ MY_CXT.yield_storage.leave_op.op_ppaddr = NULL;
+
+ Zero(&(MY_CXT.yield_storage.proxy_op), 1, OP);
+ MY_CXT.yield_storage.proxy_op.op_type = OP_STUB;
+ MY_CXT.yield_storage.proxy_op.op_ppaddr = NULL;
+
+ MY_CXT.uplevel_storage.top = NULL;
+ MY_CXT.uplevel_storage.root = NULL;
+ MY_CXT.uplevel_storage.count = 0;
+
+ MY_CXT.uid_storage.map = NULL;
+ MY_CXT.uid_storage.used = 0;
+ MY_CXT.uid_storage.alloc = 0;
+
+ call_atexit(su_local_teardown, NULL);
+
+ return;
+}
+
+/* --- XS ------------------------------------------------------------------ */
+
+#define SU_GET_CONTEXT(A, B, D) \
+ STMT_START { \
+ if (items > A) { \
+ SV *csv = ST(B); \
+ if (!SvOK(csv)) \
+ goto default_cx; \
+ cxix = SvIV(csv); \
+ if (cxix < 0) \
+ cxix = 0; \
+ else if (cxix > cxstack_ix) \
+ goto default_cx; \
+ } else { \
+default_cx: \
+ cxix = (D); \
+ } \
+ } STMT_END
+
+#define SU_GET_LEVEL(A, B) \
+ STMT_START { \
+ level = 0; \
+ if (items > 0) { \
+ SV *lsv = ST(B); \
+ if (SvOK(lsv)) { \
+ level = SvIV(lsv); \
+ if (level < 0) \
+ level = 0; \
+ } \
+ } \
+ } STMT_END
+
+#if SU_HAS_PERL(5, 10, 0)
+# define SU_INFO_COUNT 11
+#else
+# define SU_INFO_COUNT 10
+#endif
+
+XS(XS_Scope__Upper_unwind) {
+#ifdef dVAR
+ dVAR; dXSARGS;
+#else
+ dXSARGS;
+#endif
+ dMY_CXT;
+ I32 cxix;
+
+ PERL_UNUSED_VAR(cv); /* -W */
+ PERL_UNUSED_VAR(ax); /* -Wall */
+
+ SU_GET_CONTEXT(0, items - 1, cxstack_ix);
+ do {
+ 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:
+ MY_CXT.unwind_storage.cxix = cxix;
+ MY_CXT.unwind_storage.items = items;
+ MY_CXT.unwind_storage.savesp = PL_stack_sp;
+ if (items > 0) {
+ MY_CXT.unwind_storage.items--;
+ MY_CXT.unwind_storage.savesp--;
+ }
+ /* pp_entersub will want to sanitize the stack after returning from there
+ * Screw that, we're insane!
+ * dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */
+ if (GIMME_V == G_SCALAR)
+ PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
+ SAVEDESTRUCTOR_X(su_unwind, NULL);
+ return;
+ default:
+ break;
+ }
+ } while (--cxix >= 0);
+ croak("Can't return outside a subroutine");
+}
+
+static const char su_yield_name[] = "yield";
+
+XS(XS_Scope__Upper_yield) {
+#ifdef dVAR
+ dVAR; dXSARGS;
+#else
+ dXSARGS;
+#endif
+ dMY_CXT;
+ I32 cxix;
+
+ PERL_UNUSED_VAR(cv); /* -W */
+ PERL_UNUSED_VAR(ax); /* -Wall */
+
+ SU_GET_CONTEXT(0, items - 1, su_context_here());
+ MY_CXT.yield_storage.cxix = cxix;
+ MY_CXT.yield_storage.items = items;
+ MY_CXT.yield_storage.savesp = PL_stack_sp;
+ if (items > 0) {
+ MY_CXT.yield_storage.items--;
+ MY_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
+ dMY_CXT;
+
+ PERL_UNUSED_VAR(cv); /* -W */
+ PERL_UNUSED_VAR(ax); /* -Wall */
+
+ MY_CXT.yield_storage.cxix = su_context_here();
+ MY_CXT.yield_storage.items = items;
+ MY_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:
+{
+ su_global_setup(file);
+ su_local_setup();
+}
+
+#if SU_THREADSAFE
+
+void
+CLONE(...)
+PROTOTYPE: DISABLE
+PREINIT:
+ su_uid_storage new_cxt;
+PPCODE:
+ {
+ dMY_CXT;
+ new_cxt.map = NULL;
+ new_cxt.used = 0;
+ new_cxt.alloc = 0;
+ su_uid_storage_dup(&new_cxt, &MY_CXT.uid_storage, MY_CXT.uid_storage.used);
+ }
+ {
+ MY_CXT_CLONE;
+ MY_CXT.uplevel_storage.top = NULL;
+ MY_CXT.uplevel_storage.root = NULL;
+ MY_CXT.uplevel_storage.count = 0;
+ MY_CXT.uid_storage = new_cxt;
+ }
+ XSRETURN(0);
+
+#endif /* SU_THREADSAFE */
+
+void
+HERE()
+PROTOTYPE:
+PREINIT:
+ I32 cxix;
+PPCODE:
+ cxix = 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);
+ } 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;
+ 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:
+ 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);
+ }
+ 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);
+ 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;
+ }
+ /* eval text (6) and is_require (7) */
+ switch (CxTYPE(cx)) {
+ case CXt_EVAL:
+ if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
+ /* eval STRING */
+#if SU_HAS_PERL(5, 17, 4)
+ PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
+ SvCUR(cx->blk_eval.cur_text)-2,
+ SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
+#else
+ PUSHs(cx->blk_eval.cur_text);
+#endif
+ PUSHs(&PL_sv_no);
+ break;
+ } else if (cx->blk_eval.old_namesv) {
+ /* require */
+ PUSHs(sv_mortalcopy(cx->blk_eval.old_namesv));
+ PUSHs(&PL_sv_yes);
+ break;
+ }
+ /* FALLTHROUGH */
+ default:
+ /* Anything else including eval BLOCK */
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_undef);
+ break;
+ }
+ /* hints (8) */
+ mPUSHi(CopHINTS_get(cop));
+ /* warnings (9) */
+ {
+ SV *mask = NULL;
+#if SU_HAS_PERL(5, 9, 4)
+ STRLEN *old_warnings = cop->cop_warnings;
+#else
+ SV *old_warnings = cop->cop_warnings;
+#endif
+ if (old_warnings == pWARN_STD) {
+ if (PL_dowarn & G_WARN_ON)
+ goto context_info_warnings_on;
+ else
+#if SU_HAS_PERL(5, 17, 4)
+ mask = &PL_sv_undef;
+#else
+ goto context_info_warnings_off;
+#endif
+ } else if (old_warnings == pWARN_NONE) {
+#if !SU_HAS_PERL(5, 17, 4)
+context_info_warnings_off:
+#endif
+ mask = su_newmortal_pvn(WARN_NONEstring, WARNsize);
+ } else if (old_warnings == pWARN_ALL) {
+ HV *bits;
+context_info_warnings_on:
+#if SU_HAS_PERL(5, 8, 7)
+ bits = get_hv("warnings::Bits", 0);
+ if (bits) {
+ SV **bits_all = hv_fetchs(bits, "all", FALSE);
+ if (bits_all)
+ mask = sv_mortalcopy(*bits_all);
+ }
+#endif
+ if (!mask)
+ mask = su_newmortal_pvn(WARN_ALLstring, WARNsize);
+ } else {
+#if SU_HAS_PERL(5, 9, 4)
+ mask = su_newmortal_pvn((char *) (old_warnings + 1), old_warnings[0]);
+#else
+ mask = sv_mortalcopy(old_warnings);
+#endif
+ }
+ PUSHs(mask);
+ }
+#if SU_HAS_PERL(5, 10, 0)
+ /* hints hash (10) */
+ {
+ COPHH *hints_hash = CopHINTHASH_get(cop);
+ if (hints_hash) {
+ SV *rhv = sv_2mortal(newRV_noinc((SV *) cophh_2hv(hints_hash, 0)));
+ PUSHs(rhv);
+ } else {
+ PUSHs(&PL_sv_undef);
+ }
+ }
+#endif
+ XSRETURN(SU_INFO_COUNT);
+
+void
+reap(SV *hook, ...)
+PROTOTYPE: &;$
+PREINIT:
+ I32 cxix;
+ su_ud_reap *ud;
+CODE:
+ SU_GET_CONTEXT(1, 1, su_context_skip_db(cxstack_ix));
+ cxix = su_context_normalize_down(cxix);
+ Newx(ud, 1, su_ud_reap);
+ SU_UD_TYPE(ud) = SU_UD_TYPE_REAP;
+ ud->cb = (SvROK(hook) && SvTYPE(SvRV(hook)) >= SVt_PVCV)
+ ? SvRV(hook) : hook;
+ SvREFCNT_inc_simple_void(ud->cb);
+ su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);
+