+/* --- 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, *uid;
+ 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] = NULL;
+
+ MY_CXT.uid_storage.map = map;
+ MY_CXT.uid_storage.alloc = depth + 1;
+ }
+
+ uid = map[depth];
+
+ if (!uid) {
+ Newx(uid, 1, su_uid);
+ uid->seq = 0;
+ uid->flags = 0;
+ map[depth] = uid;
+ }
+
+ if (depth >= MY_CXT.uid_storage.used)
+ MY_CXT.uid_storage.used = depth + 1;
+
+ return uid;
+}
+
+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 && (uid->seq == seq) && (uid->flags & SU_UID_ACTIVE);
+}
+
+static void su_uid_drop(pTHX_ void *ud_) {
+ su_uid *uid = ud_;
+
+ uid->flags &= ~SU_UID_ACTIVE;
+}
+
+static void su_uid_bump(pTHX_ void *ud_) {
+ su_ud_reap *ud = ud_;
+
+ SAVEDESTRUCTOR_X(su_uid_drop, ud->cb);
+
+ SU_UD_FREE(ud);
+}
+
+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_reap *ud;
+
+ uid->seq = su_uid_seq_next(depth);
+ uid->flags |= SU_UID_ACTIVE;
+
+ Newx(ud, 1, su_ud_reap);
+ SU_UD_ORIGIN(ud) = NULL;
+ SU_UD_HANDLER(ud) = su_uid_bump;
+ ud->cb = (SV *) uid;
+ 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 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;
+}
+