README
Upper.xs
lib/Scope/Upper.pm
+samples/bench_uplevel.pl
samples/tag.pl
samples/try.pl
t/00-load.t
t/55-unwind-multi.t
t/56-unwind-context.t
t/59-unwind-threads.t
+t/60-uplevel-target.t
+t/61-uplevel-args.t
+t/62-uplevel-return.t
+t/63-uplevel-ctl.t
+t/64-uplevel-caller.t
+t/65-uplevel-multi.t
+t/66-uplevel-context.t
+t/67-uplevel-scope.t
+t/69-uplevel-threads.t
t/81-stress-level.t
t/85-stress-unwind.t
+t/86-stress-uplevel.t
t/91-pod.t
t/92-pod-coverage.t
t/95-portability-files.t
/* --- Compatibility ------------------------------------------------------- */
+#ifndef NOOP
+# define NOOP
+#endif
+
+#ifndef dNOOP
+# define dNOOP
+#endif
+
#ifndef PERL_UNUSED_VAR
# define PERL_UNUSED_VAR(V)
#endif
# define Newx(v, n, c) New(0, v, n, c)
#endif
+#ifdef DEBUGGING
+# ifdef PoisonNew
+# define SU_POISON(D, N, T) PoisonNew((D), (N), T)
+# elif defined(Poison)
+# define SU_POISON(D, N, T) Poison((D), (N), T)
+# endif
+#endif
+#ifndef SU_POISON
+# define SU_POISON(D, N, T) NOOP
+#endif
+
#ifndef SvPV_const
# define SvPV_const(S, L) SvPV(S, L)
#endif
# define GvCV_set(G, C) (GvCV(G) = (C))
#endif
+#ifndef CvGV_set
+# define CvGV_set(C, G) (CvGV(C) = (G))
+#endif
+
+#ifndef CxHASARGS
+# define CxHASARGS(C) ((C)->blk_sub.hasargs)
+#endif
+
#ifndef HvNAME_get
# define HvNAME_get(H) HvNAME(H)
#endif
# define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D))
#endif
+#ifndef cv_clone
+# define cv_clone(P) Perl_cv_clone(aTHX_ (P))
+#endif
+
#ifndef PERL_MAGIC_tied
# define PERL_MAGIC_tied 'P'
#endif
/* --- Threads and multiplicity -------------------------------------------- */
-#ifndef NOOP
-# define NOOP
-#endif
-
-#ifndef dNOOP
-# define dNOOP
-#endif
-
#ifndef SU_MULTIPLICITY
# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
# define SU_MULTIPLICITY 1
# define MY_CXT_CLONE NOOP
#endif
+/* --- uplevel() data tokens ----------------------------------------------- */
+
+typedef struct {
+ void *next;
+
+ I32 cxix;
+ CV *target;
+ bool died;
+
+ PERL_SI *si;
+ PERL_SI *old_curstackinfo;
+ AV *old_mainstack;
+
+ I32 old_depth;
+ COP *old_curcop;
+
+ bool old_catch;
+ OP *old_op;
+ CV *cloned_cv;
+} su_uplevel_ud;
+
+STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) {
+#define su_uplevel_ud_new() su_uplevel_ud_new(aTHX)
+ su_uplevel_ud *sud;
+ PERL_SI *si;
+
+ Newx(sud, 1, su_uplevel_ud);
+ sud->next = NULL;
+
+ Newx(si, 1, PERL_SI);
+ si->si_stack = newAV();
+ AvREAL_off(si->si_stack);
+ si->si_cxstack = NULL;
+ sud->si = si;
+
+ return sud;
+}
+
+STATIC void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) {
+#define su_uplevel_ud_delete(S) su_uplevel_ud_delete(aTHX_ (S))
+ PERL_SI *si = sud->si;
+
+ Safefree(si->si_cxstack);
+ SvREFCNT_dec(si->si_stack);
+ Safefree(si);
+ Safefree(sud);
+
+ return;
+}
+
+typedef struct {
+ su_uplevel_ud *root;
+ I32 count;
+} su_uplevel_storage;
+
+#ifndef SU_UPLEVEL_STORAGE_SIZE
+# define SU_UPLEVEL_STORAGE_SIZE 4
+#endif
+
/* --- Global data --------------------------------------------------------- */
#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
typedef struct {
char *stack_placeholder;
+
I32 cxix;
I32 items;
SV **savesp;
LISTOP return_op;
OP proxy_op;
+
+ su_uplevel_storage uplevel_storage;
} my_cxt_t;
START_MY_CXT
PL_op = &(MY_CXT.proxy_op);
}
+/* --- Uplevel ------------------------------------------------------------- */
+
+#ifndef OP_GIMME_REVERSE
+STATIC U8 su_op_gimme_reverse(U8 gimme) {
+ switch (gimme) {
+ case G_VOID:
+ return OPf_WANT_VOID;
+ case G_ARRAY:
+ return OPf_WANT_LIST;
+ default:
+ break;
+ }
+
+ return OPf_WANT_SCALAR;
+}
+#define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G)
+#endif
+
+#define SU_UPLEVEL_SAVE(f, t) STMT_START { sud->old_##f = PL_##f; PL_##f = (t); } STMT_END
+#define SU_UPLEVEL_RESTORE(f) STMT_START { PL_##f = sud->old_##f; } STMT_END
+
+STATIC int su_uplevel_restore_free(pTHX_ SV *sv, MAGIC *mg) {
+ su_uplevel_ud_delete((su_uplevel_ud *) mg->mg_ptr);
+
+ return 0;
+}
+
+STATIC MGVTBL su_uplevel_restore_vtbl = {
+ 0,
+ 0,
+ 0,
+ 0,
+ su_uplevel_restore_free
+};
+
+STATIC void su_uplevel_restore(pTHX_ void *sus_) {
+ su_uplevel_ud *sud = sus_;
+ PERL_SI *cur = sud->old_curstackinfo;
+ PERL_SI *si = sud->si;
+ dMY_CXT;
+
+ /* When we reach this place, POPSUB has already been called (with our fake
+ * argarray). GvAV(PL_defgv) points to the savearray (that is, what @_ was
+ * before uplevel). argarray is either the fake AV we created in su_uplevel()
+ * or some empty replacement POPSUB creates when @_ is reified. In both cases
+ * we have to destroy it before the context stack is swapped back to its
+ * original state. */
+ SvREFCNT_dec(cxstack[sud->cxix].blk_sub.argarray);
+
+ CATCH_SET(sud->old_catch);
+
+ SvREFCNT_dec(sud->cloned_cv);
+
+ SU_UPLEVEL_RESTORE(op);
+
+ /* stack_grow() wants PL_curstack so restore the old stack first */
+ if (PL_curstackinfo == si) {
+ PL_curstack = cur->si_stack;
+ if (sud->old_mainstack)
+ SU_UPLEVEL_RESTORE(mainstack);
+ SU_UPLEVEL_RESTORE(curstackinfo);
+
+ if (sud->died) {
+ CV *target_cv = sud->target;
+ I32 levels = 0, i;
+
+ /* When we die, the depth of the target CV is not updated because of the
+ * stack switcheroo. So we have to look at all the frames between the
+ * uplevel call and the catch block to count how many call frames to the
+ * target CV were skipped. */
+ for (i = cur->si_cxix; i > sud->cxix; i--) {
+ register const PERL_CONTEXT *cx = cxstack + i;
+
+ if (CxTYPE(cx) == CXt_SUB) {
+ if (cx->blk_sub.cv == target_cv)
+ ++levels;
+ }
+ }
+
+ /* If we died, the replacement stack was already unwinded to the first
+ * eval frame, and all the contexts down there were popped. We don't have
+ * to pop manually any context of the original stack, because they must
+ * have been in the replacement stack as well (since the second was copied
+ * from the first). Thus we only have to make sure the original stack index
+ * points to the context just below the first eval scope under the target
+ * frame. */
+ for (; i >= 0; i--) {
+ register const PERL_CONTEXT *cx = cxstack + i;
+
+ switch (CxTYPE(cx)) {
+ case CXt_SUB:
+ if (cx->blk_sub.cv == target_cv)
+ ++levels;
+ break;
+ case CXt_EVAL:
+ goto found_it;
+ break;
+ default:
+ break;
+ }
+ }
+
+found_it:
+ CvDEPTH(target_cv) = sud->old_depth - levels;
+ PL_curstackinfo->si_cxix = i - 1;
+
+#if !SU_HAS_PERL(5, 13, 1)
+ /* Since $@ was maybe localized between the target frame and the uplevel
+ * call, we forcefully flush the save stack to get rid of it and then
+ * reset $@ to its proper value. Note that the the call to
+ * su_uplevel_restore() must happen before the "reset $@" item of the save
+ * stack is processed, as uplevel was called after the localization.
+ * Andrew's change to how $@ was treated, which were mainly integrated
+ * between perl 5.13.0 and 5.13.1, fixed this. */
+ if (ERRSV && SvTRUE(ERRSV)) {
+ register const PERL_CONTEXT *cx = cxstack + i; /* This is the eval scope */
+ SV *errsv = SvREFCNT_inc(ERRSV);
+ PL_scopestack_ix = cx->blk_oldscopesp;
+ leave_scope(PL_scopestack[PL_scopestack_ix]);
+ sv_setsv(ERRSV, errsv);
+ SvREFCNT_dec(errsv);
+ }
+#endif
+ }
+ }
+
+ SU_UPLEVEL_RESTORE(curcop);
+
+ SvREFCNT_dec(sud->target);
+
+ PL_stack_base = AvARRAY(cur->si_stack);
+ PL_stack_sp = PL_stack_base + AvFILLp(cur->si_stack);
+ PL_stack_max = PL_stack_base + AvMAX(cur->si_stack);
+
+#if SU_HAS_PERL(5, 8, 0)
+ if (MY_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) {
+ /* When an exception is thrown from the uplevel'd subroutine,
+ * su_uplevel_restore() may be called by the LEAVE in die_unwind() (called
+ * die_where() in more recent perls), which has the sad habit of keeping a
+ * pointer to the current context frame across this call. This means that
+ * we can't free the temporary context stack we used for the uplevel call
+ * right now, or that pointer upwards would point to garbage. We work around
+ * this by attaching the state data to a scalar that will be freed "soon".
+ * This issue has been fixed in perl with commit 8f89e5a9. */
+ SV *sv = sv_newmortal();
+ sv_magicext(sv, NULL, PERL_MAGIC_ext, &su_uplevel_restore_vtbl,
+ (const char *) sud, 0);
+ } else {
+#endif
+ sud->next = MY_CXT.uplevel_storage.root;
+ MY_CXT.uplevel_storage.root = sud;
+ MY_CXT.uplevel_storage.count++;
+#if SU_HAS_PERL(5, 8, 0)
+ }
+#endif
+
+ return;
+}
+
+STATIC CV *su_cv_clone(pTHX_ CV *old_cv) {
+#define su_cv_clone(C) su_cv_clone(aTHX_ (C))
+ CV *new_cv;
+
+ /* Starting from commit b5c19bd7, cv_clone() has an assert that checks whether
+ * CvDEPTH(CvOUTSIDE(proto)) > 0, so we have to fool cv_clone() with a little
+ * dance. */
+#if defined(DEBUGGING) && SU_HAS_PERL(5, 9, 0)
+ I32 old_depth;
+ CV *outside = CvOUTSIDE(old_cv);
+
+ if (outside && CvCLONE(outside) && !CvCLONED(outside))
+ outside = find_runcv(NULL);
+ old_depth = CvDEPTH(outside);
+ if (!old_depth)
+ CvDEPTH(outside) = 1;
+#endif
+
+ new_cv = cv_clone(old_cv);
+
+#if defined(DEBUGGING) && SU_HAS_PERL(5, 9, 0)
+ CvDEPTH(outside) = old_depth;
+#endif
+
+ /* Starting from perl 5.9 (more exactly commit b5c19bd7), cv_clone() is no
+ * longer able to clone named subs propery. With this commit, pad_findlex()
+ * stores the parent index of a fake pad entry in the NV slot of the
+ * corresponding pad name SV, but only for anonymous subs (since named subs
+ * aren't supposed to be cloned in pure Perl land). To fix this, we just
+ * manually relink the new fake pad entries to the new ones.
+ * For some reason perl 5.8 crashes too without this, supposedly because of
+ * other closure bugs. Hence we enable it everywhere. */
+ if (!CvCLONE(old_cv)) {
+ const AV *old_padname = (const AV *) AvARRAY(CvPADLIST(old_cv))[0];
+ AV *old_pad = (AV *) AvARRAY(CvPADLIST(old_cv))[1];
+ AV *new_pad = (AV *) AvARRAY(CvPADLIST(new_cv))[1];
+ const SV **old_aryname = (const SV **) AvARRAY(old_padname);
+ SV **old_ary = AvARRAY(old_pad);
+ SV **new_ary = AvARRAY(new_pad);
+ I32 fname = AvFILLp(old_padname);
+ I32 fpad = AvFILLp(old_pad);
+ I32 ix;
+
+ for (ix = fpad; ix > 0; ix--) {
+ const SV *namesv = (ix <= fname) ? old_aryname[ix] : NULL;
+
+ if (namesv && namesv != &PL_sv_undef && SvFAKE(namesv)) {
+ SvREFCNT_dec(new_ary[ix]);
+ new_ary[ix] = SvREFCNT_inc(old_ary[ix]);
+ }
+ }
+ }
+
+ return new_cv;
+}
+
+STATIC I32 su_uplevel(pTHX_ CV *cv, I32 cxix, I32 args) {
+#define su_uplevel(C, I, A) su_uplevel(aTHX_ (C), (I), (A))
+ su_uplevel_ud *sud;
+ const PERL_CONTEXT *cx = cxstack + cxix;
+ PERL_SI *si;
+ PERL_SI *cur = PL_curstackinfo;
+ SV **old_stack_sp;
+ CV *target_cv;
+ UNOP sub_op;
+ I32 marksize;
+ I32 gimme;
+ I32 old_mark, new_mark;
+ I32 ret;
+ dSP;
+ dMY_CXT;
+
+ ENTER;
+
+ 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 = MY_CXT.uplevel_storage.root;
+ if (sud) {
+ MY_CXT.uplevel_storage.root = sud->next;
+ MY_CXT.uplevel_storage.count--;
+ } else {
+ sud = su_uplevel_ud_new();
+ }
+ si = sud->si;
+
+ sud->cxix = cxix;
+ sud->died = 1;
+ SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
+
+ si->si_type = cur->si_type;
+ si->si_next = NULL;
+ si->si_prev = cur->si_prev;
+
+ /* 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;
+
+#ifdef DEBUGGING
+ si->si_markoff = cx->blk_oldmarksp;
+#endif
+
+ /* Copy the context stack up to the context just below the target. */
+ si->si_cxix = (cxix < 0) ? -1 : (cxix - 1);
+ /* 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_cv = cx->blk_sub.cv;
+ sud->target = (CV *) SvREFCNT_inc(target_cv);
+ sud->old_depth = CvDEPTH(target_cv);
+
+ /* 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, 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;
+
+ cv = su_cv_clone(cv);
+ sud->cloned_cv = cv;
+ CvGV_set(cv, CvGV(target_cv));
+
+ PUSHMARK(SP);
+ /* Both SP and old_stack_sp points just before the CV. */
+ Copy(old_stack_sp + 2, SP + 1, args, SV *);
+ SP += args;
+ PUSHs((SV *) cv);
+ 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);
+
+ sud->old_catch = CATCH_GET;
+ CATCH_SET(TRUE);
+
+ if (PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)) {
+ 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);
+ 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 *);
+ cxstack[cxix].blk_sub.argarray = av;
+ } else if (PL_DBsub) {
+ SvREFCNT_inc(cxstack[cxix].blk_sub.argarray);
+ }
+
+ CALLRUNOPS(aTHX);
+
+ ret = PL_stack_sp - (PL_stack_base + new_mark);
+ }
+
+ sud->died = 0;
+
+ SPAGAIN;
+
+ 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;
+ }
+
+ PUTBACK;
+
+ LEAVE;
+
+ return ret;
+}
+
+/* --- Interpreter setup/teardown ------------------------------------------ */
+
+STATIC void su_teardown(pTHX_ void *param) {
+ su_uplevel_ud *cur, *prev;
+ dMY_CXT;
+
+ 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_setup(pTHX) {
+#define su_setup() su_setup(aTHX)
+ MY_CXT_INIT;
+
+ MY_CXT.stack_placeholder = NULL;
+
+ /* NewOp() calls calloc() which just zeroes the memory with memset(). */
+ Zero(&(MY_CXT.return_op), 1, sizeof(MY_CXT.return_op));
+ MY_CXT.return_op.op_type = OP_RETURN;
+ MY_CXT.return_op.op_ppaddr = PL_ppaddr[OP_RETURN];
+
+ Zero(&(MY_CXT.proxy_op), 1, sizeof(MY_CXT.proxy_op));
+ MY_CXT.proxy_op.op_type = OP_STUB;
+ MY_CXT.proxy_op.op_ppaddr = NULL;
+
+ MY_CXT.uplevel_storage.root = NULL;
+ MY_CXT.uplevel_storage.count = 0;
+
+ call_atexit(su_teardown, NULL);
+
+ return;
+}
+
/* --- XS ------------------------------------------------------------------ */
#if SU_HAS_PERL(5, 8, 9)
{
HV *stash;
- MY_CXT_INIT;
-
- MY_CXT.stack_placeholder = NULL;
-
- /* NewOp() calls calloc() which just zeroes the memory with memset(). */
- Zero(&(MY_CXT.return_op), 1, sizeof(MY_CXT.return_op));
- MY_CXT.return_op.op_type = OP_RETURN;
- MY_CXT.return_op.op_ppaddr = PL_ppaddr[OP_RETURN];
-
- Zero(&(MY_CXT.proxy_op), 1, sizeof(MY_CXT.proxy_op));
- MY_CXT.proxy_op.op_type = OP_STUB;
- MY_CXT.proxy_op.op_ppaddr = NULL;
-
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);
+
+ su_setup();
}
#if SU_THREADSAFE
PPCODE:
{
MY_CXT_CLONE;
+ MY_CXT.uplevel_storage.root = NULL;
+ MY_CXT.uplevel_storage.count = 0;
}
XSRETURN(0);
SU_UD_HANDLER(ud) = su_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);
+ 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;
+ }
+ ret = su_uplevel((CV *) code, cxix, args);
+ XSRETURN(ret);
+ default:
+ break;
+ }
+ } while (--cxix >= 0);
+ croak("Can't uplevel outside a subroutine");
my @stuff = zap(); # @stuff contains qw<a b c>
my $stuff = zap(); # $stuff contains 3
+L</uplevel> :
+
+ package Uplevel;
+
+ use Scope::Upper qw<uplevel CALLER>;
+
+ sub target {
+ faker(@_);
+ }
+
+ sub faker {
+ uplevel {
+ my $sub = (caller 0)[3];
+ print "$_[0] from $sub()";
+ } @_ => CALLER(1);
+ }
+
+ target('hello'); # "hello from Uplevel::target()"
+
=head1 DESCRIPTION
This module lets you defer actions I<at run-time> that will take place when the control flow returns into an upper scope.
=item *
-return values immediately to an upper level with L</unwind>, and know which context was in use then with L</want_at>.
+return values immediately to an upper level with L</unwind>, and know which context was in use then with L</want_at> ;
+
+=item *
+
+execute a subroutine in the context of an upper subroutine stack frame with L</uplevel>.
=back
will rightfully set C<$num> to C<26>.
+=head2 C<uplevel $code, @args, $context>
+
+Executes the code reference C<$code> with arguments C<@args> as if it were located at the subroutine stack frame pointed by C<$context>, effectively fooling C<caller> and C<die> into believing that the call actually happened higher in the stack.
+The code is executed in the context of the C<uplevel> call, and what it returns is returned as-is by C<uplevel>.
+
+ sub target {
+ faker(@_);
+ }
+
+ sub faker {
+ uplevel {
+ map { 1 / $_ } @_;
+ } @_ => CALLER(1);
+ }
+
+ my @inverses = target(1, 2, 4); # @inverses contains (0, 0.5, 0.25)
+ my $count = target(1, 2, 4); # $target is 3
+
+L<Sub::Uplevel> also implements a pure-Perl version of C<uplevel>.
+Both are identical, with the following caveats :
+
+=over 4
+
+=item *
+
+The L<Sub::Uplevel> implementation of C<uplevel> may execute a code reference in the context of B<any> upper stack frame.
+The L<Scope::Upper> version only allows to uplevel to a B<subroutine> stack frame, and will croak if you try to target an C<eval> or a format.
+
+=item *
+
+Exceptions thrown from the code called by this version of C<uplevel> will not be caught by C<eval> blocks between the target frame and the uplevel call, while they will for L<Sub::Uplevel>'s version.
+This means that :
+
+ eval {
+ sub {
+ local $@;
+ eval {
+ sub {
+ uplevel { die 'wut' } CALLER(2); # for Scope::Upper
+ # uplevel(3, sub { die 'wut' }) # for Sub::Uplevel
+ }->();
+ };
+ print "inner block: $@";
+ $@ and exit;
+ }->();
+ };
+ print "outer block: $@";
+
+will print "inner block: wut..." with L<Sub::Uplevel> and "outer block: wut..." with L<Scope::Upper>.
+
+=item *
+
+L<Sub::Uplevel> globally overrides C<CORE::GLOBAL::caller>, while L<Scope::Upper> does not.
+
+=back
+
+A simple wrapper lets you mimic the interface of L<Sub::Uplevel/uplevel> :
+
+ use Scope::Upper;
+
+ sub uplevel {
+ my $frame = shift;
+ my $code = shift;
+ my $cxt = Scope::Upper::CALLER($frame);
+ &Scope::Upper::uplevel($code => @_ => $cxt);
+ }
+
+Albeit the three exceptions listed above, it passes all the tests of L<Sub::Uplevel>.
+
=head1 CONSTANTS
=head2 C<SU_THREADSAFE>
# $cxt = SCOPE(4), UP SUB UP SUB, or UP SUB EVAL, or UP CALLER(2), or TOP
...
-Where L</unwind> and L</want_at> point to depending on the C<$cxt>:
+Where L</unwind>, L</want_at> and L</uplevel> point to depending on the C<$cxt>:
sub {
eval {
sub {
{
- unwind @things => $cxt;
+ unwind @things => $cxt; # or uplevel { ... } $cxt;
...
}
...
}->(); # $cxt = SCOPE(0 .. 1), or HERE, or UP, or SUB, or CALLER(0)
...
- }; # $cxt = SCOPE(2), or UP UP, or UP SUB, or EVAL, or CALLER(1)
+ }; # $cxt = SCOPE(2), or UP UP, or UP SUB, or EVAL, or CALLER(1) (*)
...
}->(); # $cxt = SCOPE(3), or SUB UP SUB, or SUB EVAL, or CALLER(2)
...
+ # (*) Note that uplevel() will croak if you pass that scope frame,
+ # because it can't target eval scopes.
+
=head1 EXPORT
-The functions L</reap>, L</localize>, L</localize_elem>, L</localize_delete>, L</unwind> and L</want_at> are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>.
+The functions L</reap>, L</localize>, L</localize_elem>, L</localize_delete>, L</unwind>, L</want_at> and L</uplevel> are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>.
The constant L</SU_THREADSAFE> is also only exported on request, individually or by the tags C<':consts'> and C<':all'>.
our @EXPORT = ();
our %EXPORT_TAGS = (
- funcs => [ qw<reap localize localize_elem localize_delete unwind want_at> ],
+ funcs => [ qw<
+ reap
+ localize localize_elem localize_delete
+ unwind want_at
+ uplevel
+ > ],
words => [ qw<TOP HERE UP SUB EVAL SCOPE CALLER> ],
consts => [ qw<SU_THREADSAFE> ],
);
L<Scope::Escape>.
+L<Sub::Uplevel> provides a pure-Perl implementation of L</uplevel>.
+
=head1 AUTHOR
Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use blib;
+
+use Benchmark qw<cmpthese>;
+
+use Scope::Upper qw<:words>;
+BEGIN { *uplevel_xs = \&Scope::Upper::uplevel }
+
+use Sub::Uplevel;
+BEGIN { *uplevel_pp = \&Sub::Uplevel::uplevel }
+
+sub void { }
+
+sub foo_t { void { } }
+
+sub foo_pp { uplevel_pp(0, sub { }) }
+
+sub foo_xs { uplevel_xs { } }
+
+print "\nuplevel to current scope:\n";
+cmpthese -1, {
+ tare => sub { foo_t() },
+ pp => sub { foo_pp() },
+ xs => sub { foo_xs() },
+};
+
+sub bar_1_t { bar_2_t() }
+sub bar_2_t { void() }
+
+sub bar_1_pp { bar_2_pp() }
+sub bar_2_pp { uplevel_pp(1, sub { }) }
+
+sub bar_1_xs { bar_2_xs() }
+sub bar_2_xs { uplevel_xs { } UP }
+
+print "\nuplevel to one scope above:\n";
+cmpthese -1, {
+ tare => sub { bar_2_t() },
+ pp => sub { bar_2_pp() },
+ xs => sub { bar_2_xs() },
+};
+
+sub hundred { 1 .. 100 }
+
+sub baz_t { hundred() }
+
+sub baz_pp { uplevel_pp(0, sub { 1 .. 100 }) }
+
+sub baz_xs { uplevel_xs { 1 .. 100 } }
+
+print "\nreturning 100 values:\n";
+cmpthese -1, {
+ tare => sub { my @r = baz_t() },
+ pp => sub { my @r = baz_pp() },
+ xs => sub { my @r = baz_xs() },
+};
+
+my $n = 10_000;
+my $tare_code = "sub { my \@c; \@c = caller(0) for 1 .. $n }->()";
+
+print "\ncaller() slowdown:\n";
+cmpthese 30, {
+ tare => sub { system { $^X } $^X, '-e', "use blib; use List::Util; $tare_code" },
+ pp => sub { system { $^X } $^X, '-e', "use blib; use Sub::Uplevel; $tare_code" },
+ xs => sub { system { $^X } $^X, '-e', "use blib; use Scope::Upper; $tare_code" },
+}
my $stuff = zap(); # $stuff contains 3
print "zap() returns @stuff in list context and $stuff in scalar context\n";
+
+{
+ package Uplevel;
+
+ use Scope::Upper qw<uplevel CALLER>;
+
+ sub target {
+ faker(@_);
+ }
+
+ sub faker {
+ uplevel {
+ my $sub = (caller 0)[3];
+ print "$_[0] from $sub()\n";
+ } @_ => CALLER(1);
+ }
+
+ target('hello'); # "hello from Uplevel::target()"
+}
use strict;
use warnings;
-use Test::More tests => 2 * 14;
+use Test::More tests => 2 * 15;
require Scope::Upper;
localize_delete => '$$;$',
unwind => undef,
want_at => ';$',
+ uplevel => '&@',
TOP => '',
HERE => '',
UP => ';$',
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 5 + 6 + 5;
+
+use Scope::Upper qw<uplevel HERE UP TOP>;
+
+our ($desc, $target);
+
+my @cxt;
+
+sub three {
+ my ($depth, $code) = @_;
+ $cxt[0] = HERE;
+ $target = $cxt[$depth];
+ &uplevel($code => $target);
+ pass("$desc: reached end of three()");
+}
+
+my $two = sub {
+ $cxt[1] = HERE;
+ three(@_);
+ pass("$desc: reached end of \$two");
+};
+
+sub one {
+ $cxt[2] = HERE;
+ $two->(@_);
+ pass("$desc: reached end of one()");
+}
+
+sub tester_sub {
+ is(HERE, $target, "$desc: right context");
+}
+
+my $tester_anon = sub {
+ is(HERE, $target, "$desc: right context");
+};
+
+my @subs = (\&three, $two, \&one);
+
+for my $height (0 .. 2) {
+ my $base = $subs[$height];
+
+ for my $anon (0, 1) {
+ my $code = $anon ? $tester_anon : \&tester_sub;
+
+ for my $depth (0 .. $height) {
+ local $target;
+ local $desc = "uplevel at depth $depth/$height";
+ $desc .= $anon ? ' (anonymous callback)' : ' (named callback)';
+
+ local $@;
+ eval { $base->($depth, $code) };
+ is $@, '', "$desc: no error";
+ }
+ }
+}
+
+{
+ my $desc = 'uplevel called without a code reference';
+ local $@;
+ eval {
+ three(0, "wut");
+ fail "$desc: uplevel should have croaked";
+ };
+ like $@, qr/^First argument to uplevel must be a code reference/,"$desc: dies";
+}
+
+sub four {
+ my $desc = shift;
+ my $cxt = HERE;
+ uplevel { is HERE, $cxt, "$desc: right context" };
+ pass "$desc: reached end of four()";
+}
+
+{
+ my $desc = 'uplevel called without a target';
+ local $@;
+ eval {
+ four($desc);
+ };
+ is $@, '', "$desc: no error";
+}
+
+{
+ my $desc = 'uplevel to top';
+ local $@;
+ eval {
+ uplevel sub { fail "$desc: uplevel body should not be executed" }, TOP;
+ fail "$desc: uplevel should have croaked";
+ };
+ like $@, qr/^Can't uplevel outside a subroutine/, "$desc: dies";
+}
+
+{
+ my $desc = 'uplevel to eval 1';
+ local $@;
+ eval {
+ uplevel sub { fail "$desc: uplevel body should not be executed" }, HERE;
+ fail "$desc: uplevel should have croaked";
+ };
+ like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
+}
+
+{
+ my $desc = 'uplevel to eval 2';
+ local $@;
+ sub {
+ eval {
+ uplevel {
+ fail "$desc: uplevel body should not be executed"
+ };
+ fail "$desc: uplevel should have croaked";
+ };
+ return;
+ }->();
+ like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
+}
+
+# Target destruction
+
+{
+ our $destroyed;
+ sub Scope::Upper::TestCodeDestruction::DESTROY { ++$destroyed }
+
+ {
+ local $@;
+ local $destroyed = 0;
+ my $desc = 'target destruction 1';
+
+ {
+ my $lexical;
+ my $target = sub {
+ my $code = shift;
+ ++$lexical;
+ $code->();
+ };
+ $target = bless $target, 'Scope::Upper::TestCodeDestruction';
+
+ eval {
+ $target->(
+ sub {
+ uplevel {
+ is $destroyed, 0, "$desc: not yet 1";
+ } UP;
+ is $destroyed, 0, "$desc: not yet 2";
+ },
+ );
+ };
+ is $@, '', "$desc: no error";
+ is $destroyed, 0, "$desc: not yet 3";
+ }
+
+ is $destroyed, 1, "$desc: target is detroyed";
+ }
+
+ SKIP: {
+ skip 'This fails even with a plain subroutine call on 5.8.x' => 6
+ if "$]" < 5.009;
+ local $@;
+ local $destroyed = 0;
+ my $desc = 'target destruction 2';
+
+ {
+ my $lexical;
+ my $target = sub {
+ my $code = shift;
+ ++$lexical;
+ $code->();
+ };
+ $target = bless $target, 'Scope::Upper::TestCodeDestruction';
+
+ eval {
+ $target->(
+ sub {
+ uplevel {
+ $target->(sub {
+ is $destroyed, 0, "$desc: not yet 1";
+ });
+ is $destroyed, 0, "$desc: not yet 2";
+ } UP;
+ is $destroyed, 0, "$desc: not yet 3";
+ },
+ );
+ };
+ is $@, '', "$desc: no error";
+ is $destroyed, 0, "$desc: not yet 4";
+ }
+
+ is $destroyed, 1, "$desc: target is detroyed";
+ }
+
+ {
+ local $@;
+ local $destroyed = 0;
+ my $desc = 'target destruction 3';
+
+ {
+ my $lexical;
+ my $target = sub {
+ ++$lexical;
+ if (@_) {
+ my $code = shift;
+ $code->();
+ } else {
+ is $destroyed, 0, "$desc: not yet 1";
+ }
+ };
+ $target = bless $target, 'Scope::Upper::TestCodeDestruction';
+
+ eval {
+ $target->(
+ sub {
+ &uplevel($target => UP);
+ is $destroyed, 0, "$desc: not yet 2";
+ },
+ );
+ };
+ is $@, '', "$desc: no error";
+ is $destroyed, 0, "$desc: not yet 3";
+ }
+
+ is $destroyed, 1, "$desc: target is detroyed";
+ }
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 9 + 4 * 7 + 3 + 2 + 6;
+
+use Scope::Upper qw<uplevel HERE>;
+
+# Basic
+
+sub {
+ uplevel { pass 'no @_: callback' };
+ is_deeply \@_, [ 'dummy' ], 'no @_: @_ outside';
+}->('dummy');
+
+sub {
+ uplevel { is_deeply \@_, [ ], "no arguments, no context" }
+}->('dummy');
+
+sub {
+ uplevel { is_deeply \@_, [ ], "no arguments, with context" } HERE
+}->('dummy');
+
+sub {
+ uplevel { is_deeply \@_, [ 1 ], "one const argument" } 1, HERE
+}->('dummy');
+
+my $x = 2;
+sub {
+ uplevel { is_deeply \@_, [ 2 ], "one lexical argument" } $x, HERE
+}->('dummy');
+
+our $y = 3;
+sub {
+ uplevel { is_deeply \@_, [ 3 ], "one global argument" } $y, HERE
+}->('dummy');
+
+sub {
+ uplevel { is_deeply \@_, [ 4, 5 ], "two const arguments" } 4, 5, HERE
+}->('dummy');
+
+sub {
+ uplevel { is_deeply \@_, [ 1 .. 10 ], "ten const arguments" } 1 .. 10, HERE
+}->('dummy');
+
+# Reification of @_
+
+sub {
+ my @args = (1 .. 10);
+ uplevel {
+ my $r = shift;
+ is $r, 1, 'shift: result';
+ is_deeply \@_, [ 2 .. 10 ], 'shift: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1 .. 10 ], 'shift: args';
+ is_deeply \@_, [ 'dummy' ], 'shift: @_ outside';
+}->('dummy');
+
+sub {
+ my @args = (1 .. 10);
+ uplevel {
+ my $r = pop;
+ is $r, 10, 'pop: result';
+ is_deeply \@_, [ 1 .. 9 ], 'pop: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1 .. 10 ], 'pop: args';
+ is_deeply \@_, [ 'dummy' ], 'pop: @_ outside';
+}->('dummy');
+
+sub {
+ my @args = (1 .. 10);
+ uplevel {
+ my $r = unshift @_, 0;
+ is $r, 11, 'unshift: result';
+ is_deeply \@_, [ 0 .. 10 ], 'unshift: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1 .. 10 ], 'unshift: args';
+ is_deeply \@_, [ 'dummy' ], 'unshift: @_ outside';
+}->('dummy');
+
+sub {
+ my @args = (1 .. 10);
+ uplevel {
+ my $r = push @_, 11;
+ is $r, 11, 'push: result';
+ is_deeply \@_, [ 1 .. 11 ], 'push: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1 .. 10 ], 'push: args';
+ is_deeply \@_, [ 'dummy' ], 'push: @_ outside';
+}->('dummy');
+
+sub {
+ my @args = (1 .. 10);
+ uplevel {
+ my ($r) = splice @_, 4, 1;
+ is $r, 5, 'splice: result';
+ is_deeply \@_, [ 1 .. 4, 6 .. 10 ], 'splice: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1 .. 10 ], 'splice: args';
+ is_deeply \@_, [ 'dummy' ], 'splice: @_ outside';
+}->('dummy');
+
+sub {
+ my @args = (1 .. 10);
+ uplevel {
+ my ($r, $s, $t, @rest) = @_;
+ is_deeply [ $r, $s, $t, \@rest ], [ 1 .. 3, [ 4 .. 10 ] ], 'unpack 1: result';
+ is_deeply \@_, [ 1 .. 10 ], 'unpack 1: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1 .. 10 ], 'unpack 1: args';
+ is_deeply \@_, [ 'dummy' ], 'unpack 1: @_ outside';
+}->('dummy');
+
+sub {
+ my @args = (1, 2);
+ uplevel {
+ my ($r, $s, $t, @rest) = @_;
+ is_deeply [ $r, $s, $t, \@rest ], [ 1, 2, undef, [ ] ], 'unpack 2: result';
+ is_deeply \@_, [ 1, 2 ], 'unpack 2: @_ inside';
+ } @args, HERE;
+ is_deeply \@args, [ 1, 2 ], 'unpack 2: args';
+ is_deeply \@_, [ 'dummy' ], 'unpack 2: @_ outside';
+}->('dummy');
+
+# Aliasing
+
+sub {
+ my $s = 'abc';
+ uplevel {
+ $_[0] = 'xyz';
+ } $s, HERE;
+ is $s, 'xyz', 'aliasing, one layer';
+}->('dummy');
+
+sub {
+ my $s = 'abc';
+ sub {
+ uplevel {
+ $_[0] = 'xyz';
+ } $_[0], HERE;
+ is $_[0], 'xyz', 'aliasing, two layers 1';
+ }->($s);
+ is $s, 'xyz', 'aliasing, two layers 2';
+}->('dummy');
+
+# Magic
+
+{
+ package Scope::Upper::TestMagic;
+
+ sub TIESCALAR {
+ my ($class, $cb) = @_;
+ bless { cb => $cb }, $class;
+ }
+
+ sub FETCH { $_[0]->{cb}->(@_) }
+
+ sub STORE { die "Read only magic scalar" }
+}
+
+tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
+sub {
+ uplevel { is_deeply \@_, [ $$ ], "one magical argument" } $mg, HERE
+}->('dummy');
+
+tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
+sub {
+ uplevel { is_deeply \@_, [ $$ ], "one double magical argument" } $mg2, HERE
+}->('dummy');
+
+# Destruction
+
+{
+ package Scope::Upper::TestTimelyDestruction;
+
+ sub new {
+ my ($class, $flag) = @_;
+ $$flag = 0;
+ bless { flag => $flag }, $class;
+ }
+
+ sub DESTROY {
+ ${$_[0]->{flag}}++;
+ }
+}
+
+SKIP: {
+ skip 'This fails even with a plain subroutine call on 5.8.0' => 6
+ if "$]" <= 5.008;
+
+ my $destroyed;
+ {
+ my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
+ is $destroyed, 0, 'destruction: not yet 1';
+ sub {
+ is $destroyed, 0, 'destruction: not yet 2';
+ uplevel {
+ is $destroyed, 0, 'destruction: not yet 3';
+ } $z, HERE;
+ is $destroyed, 0, 'destruction: not yet 4';
+ }->('dummy');
+ is $destroyed, 0, 'destruction: not yet 5';
+ }
+ is $destroyed, 1, 'destruction: destroyed';
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => (10 + 5 + 4) * 2 + 11;
+
+use Scope::Upper qw<uplevel HERE UP>;
+
+# Basic
+
+sub check (&$$) {
+ my ($code, $exp_in, $desc) = @_;
+
+ local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
+
+ my $exp_out = [ 'A', map("X$_", @$exp_in), 'Z' ];
+
+ my @ret = sub {
+ my @ret = &uplevel($code, HERE);
+ is_deeply \@ret, $exp_in, "$desc: inside";
+ @$exp_out;
+ }->('dummy');
+
+ is_deeply \@ret, $exp_out, "$desc: outside";
+}
+
+check { return } [ ], 'empty explicit return';
+
+check { () } [ ], 'empty implicit return';
+
+check { return 1 } [ 1 ], 'one const scalar explicit return';
+
+check { 2 } [ 2 ], 'one const scalar implicit return';
+
+{
+ my $x = 3;
+ check { return $x } [ 3 ], 'one lexical scalar explicit return';
+}
+
+{
+ my $x = 4;
+ check { $x } [ 4 ], 'one lexical scalar implicit return';
+}
+
+{
+ our $x = 3;
+ check { return $x } [ 3 ], 'one global scalar explicit return';
+}
+
+{
+ our $x = 4;
+ check { $x } [ 4 ], 'one global scalar implicit return';
+}
+
+check { return 1 .. 5 } [ 1 .. 5 ], 'five const scalar explicit return';
+
+check { 6 .. 10 } [ 6 .. 10 ], 'five const scalar implicit return';
+
+# Mark
+
+{
+ my $desc = 'one scalar explict return between two others, without args';
+ my @ret = sub {
+ my @ret = (1, uplevel(sub { return 2 }), 3);
+ is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
+ qw<X Y>;
+ }->('dummy');
+ is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
+}
+
+{
+ my $desc = 'one scalar implict return between two others, without args';
+ my @ret = sub {
+ my @ret = (4, uplevel(sub { 5 }), 6);
+ is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
+ qw<X Y>;
+ }->('dummy');
+ is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
+}
+
+{
+ my $desc = 'one scalar explict return between two others, with args';
+ my @ret = sub {
+ my @ret = (1, uplevel(sub { return 2 }, 7 .. 9, HERE), 3);
+ is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
+ qw<X Y>;
+ }->('dummy');
+ is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
+}
+
+{
+ my $desc = 'one scalar implict return between two others, with args';
+ my @ret = sub {
+ my @ret = (4, uplevel(sub { 5 }, 7 .. 9, HERE), 6);
+ is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
+ qw<X Y>;
+ }->('dummy');
+ is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
+}
+
+{
+ my $desc = 'complex chain of calls';
+
+ sub one { "<", two("{", @_, "}"), ">" }
+ sub two { "(", three("[", @_, "]"), ")" }
+ sub three { (uplevel { "A", "B", four(@_) } @_, UP), "Z" }
+ sub four {
+ is_deeply \@_, [ qw|[ { * } ]| ], "$desc: inside";
+ @_
+ }
+
+ my @ret = one('*');
+ is_deeply \@ret, [ qw|< ( A B [ { * } ] Z ) >| ], "$desc: outside";
+}
+
+# Magic
+
+{
+ package Scope::Upper::TestMagic;
+
+ sub TIESCALAR {
+ my ($class, $cb) = @_;
+ bless { cb => $cb }, $class;
+ }
+
+ sub FETCH { $_[0]->{cb}->(@_) }
+
+ sub STORE { die "Read only magic scalar" }
+}
+
+{
+ tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
+ check { return $mg } [ $$ ], 'one magical scalar explicit return';
+ check { $mg } [ $$ ], 'one magical scalar implicit return';
+
+ tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
+ check { return $mg2 } [ $$ ], 'one double magical scalar explicit return';
+ check { $mg2 } [ $$ ], 'one double magical scalar implicit return';
+}
+
+# Destruction
+
+{
+ package Scope::Upper::TestTimelyDestruction;
+
+ sub new {
+ my ($class, $flag) = @_;
+ $$flag = 0;
+ bless { flag => $flag }, $class;
+ }
+
+ sub DESTROY {
+ ${$_[0]->{flag}}++;
+ }
+}
+
+{
+ my $destroyed;
+ {
+ sub {
+ my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
+ is $destroyed, 0, 'destruction 1: not yet 1';
+ uplevel {
+ is $destroyed, 0, 'destruction 1: not yet 2';
+ $z;
+ }, do { is $destroyed, 0, 'destruction 1: not yet 3'; () }
+ }->('dummy');
+ is $destroyed, 1, 'destruction 1: destroyed 1';
+ }
+ is $destroyed, 1, 'destruction 1: destroyed 2';
+}
+
+SKIP: {
+ skip 'This fails even with a plain subroutine call on 5.8.x' => 6
+ if "$]" < 5.009;
+
+ my $destroyed;
+ {
+ my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
+ is $destroyed, 0, 'destruction 2: not yet 1';
+ sub {
+ is $destroyed, 0, 'destruction 2: not yet 2';
+ (uplevel {
+ is $destroyed, 0, 'destruction 2: not yet 3';
+ return $z;
+ }), do { is $destroyed, 0, 'destruction 2: not yet 4'; () }
+ }->('dummy');
+ is $destroyed, 0, 'destruction 2: not yet 5';
+ }
+ is $destroyed, 1, 'destruction 2: destroyed';
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 3 + (3 + 4 + 4) + (3 + 4 + 4) + 5 + 3*3 + (4 + 7);
+
+use Scope::Upper qw<uplevel HERE SUB CALLER>;
+
+sub depth {
+ my $depth = 0;
+ while (1) {
+ my @c = caller($depth);
+ last unless @c;
+ ++$depth;
+ }
+ return $depth - 1;
+}
+
+is depth(), 0, 'check top depth';
+is sub { depth() }->(), 1, 'check subroutine call depth';
+is do { local $@; eval { depth() } }, 1, 'check eval block depth';
+
+{
+ my $desc = 'exception with no eval in between 1';
+ local $@;
+ eval {
+ sub {
+ is depth(), 2, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 2";
+ die 'cabbage';
+ };
+ fail "$desc: not reached 1";
+ }->();
+ fail "$desc: not reached 2";
+ };
+ my $line = __LINE__-6;
+ like $@, qr/^cabbage at \Q$0\E line $line/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with no eval in between 2';
+ local $@;
+ eval {
+ sub {
+ is depth(), 2, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 2";
+ sub {
+ is depth(), 3, "$desc: correct depth 3";
+ die 'lettuce';
+ }->();
+ };
+ fail "$desc: not reached 1";
+ }->();
+ fail "$desc: not reached 2";
+ };
+ my $line = __LINE__-7;
+ like $@, qr/^lettuce at \Q$0\E line $line/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with no eval in between 3';
+ local $@;
+ eval q[
+ sub {
+ is depth(), 2, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 2";
+ sub {
+ is depth(), 3, "$desc: correct depth 3";
+ die 'onion';
+ }->();
+ };
+ fail "$desc: not reached 1";
+ }->();
+ fail "$desc: not reached 2";
+ ];
+ like $@, qr/^onion at \(eval \d+\) line 8/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with an eval in between 1';
+ local $@;
+ eval {
+ sub {
+ eval {
+ is depth(), 3, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 2";
+ die 'macaroni';
+ } SUB;
+ fail "$desc: not reached 1";
+ };
+ fail "$desc: not reached 2";
+ }->();
+ fail "$desc: not reached 3";
+ };
+ my $line = __LINE__-8;
+ like $@, qr/^macaroni at \Q$0\E line $line/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with an eval in between 2';
+ local $@;
+ eval {
+ sub {
+ eval {
+ is depth(), 3, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 1";
+ sub {
+ is depth(), 3, "$desc: correct depth 1";
+ die 'spaghetti';
+ }->();
+ } SUB;
+ fail "$desc: not reached 1";
+ };
+ fail "$desc: not reached 2";
+ }->();
+ fail "$desc: not reached 3";
+ };
+ my $line = __LINE__-9;
+ like $@, qr/^spaghetti at \Q$0\E line $line/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with an eval in between 3';
+ local $@;
+ eval {
+ sub {
+ eval q[
+ is depth(), 3, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 1";
+ sub {
+ is depth(), 3, "$desc: correct depth 1";
+ die 'ravioli';
+ }->();
+ } SUB;
+ fail "$desc: not reached 1";
+ ];
+ fail "$desc: not reached 2";
+ }->();
+ fail "$desc: not reached 3";
+ };
+ like $@, qr/^ravioli at \(eval \d+\) line 7/, "$desc: correct exception";
+}
+our $hurp;
+
+SKIP: {
+ skip "Causes failures during global destruction on perl 5.8.[0126]" => 5
+ if ("$]" >= 5.008 and "$]" <= 5.008002) or "$]" == 5.008006;
+ my $desc = 'exception with an eval and a local $@ in between';
+ local $hurp = 'durp';
+ local $@;
+ my $x = (eval {
+ sub {
+ local $@;
+ eval {
+ sub {
+ is depth(), 4, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 2";
+ die 'lasagna'
+ } CALLER(2);
+ fail "$desc: not reached 1";
+ }->();
+ fail "$desc: not reached 2";
+ };
+ fail "$desc: not reached 3";
+ }->();
+ fail "$desc: not reached 4";
+ }, $@);
+ my $line = __LINE__-10;
+ like $@, qr/^lasagna at \Q$0\E line $line/, "$desc: correct exception";
+ like $x, qr/^lasagna at \Q$0\E line $line/, "$desc: \$@ timely reset";
+ is $hurp, 'durp', "$desc: force save stack flushing didn't go too far";
+}
+
+{
+ my $desc = 'several exceptions in a row';
+ local $@;
+ eval {
+ sub {
+ is depth(), 2, "$desc (first): correct depth";
+ uplevel {
+ is depth(), 2, "$desc (first): correct depth";
+ die 'carrot';
+ };
+ fail "$desc (first): not reached 1";
+ }->();
+ fail "$desc (first): not reached 2";
+ };
+ my $line = __LINE__-6;
+ like $@, qr/^carrot at \Q$0\E line $line/, "$desc (first): correct exception";
+ eval {
+ sub {
+ is depth(), 2, "$desc (second): correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc (second): correct depth 2";
+ die 'potato';
+ };
+ fail "$desc (second): not reached 1";
+ }->();
+ fail "$desc (second): not reached 2";
+ };
+ $line = __LINE__-6;
+ like $@, qr/^potato at \Q$0\E line $line/, "$desc (second): correct exception";
+ eval {
+ sub {
+ is depth(), 2, "$desc (third): correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc (third): correct depth 2";
+ die 'tomato';
+ };
+ fail "$desc (third): not reached 1";
+ }->();
+ fail "$desc (third): not reached 2";
+ };
+ $line = __LINE__-6;
+ like $@, qr/^tomato at \Q$0\E line $line/, "$desc (third): correct exception";
+}
+
+my $has_B = do { local $@; eval 'require B; 1' };
+
+sub check_depth {
+ my ($code, $expected, $desc) = @_;
+
+ SKIP: {
+ skip 'B.pm is needed to check CV depth' => 1 unless $has_B;
+
+ local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
+
+ my $depth = B::svref_2object($code)->DEPTH;
+ is $depth, $expected, $desc;
+ }
+}
+
+sub bonk {
+ my ($code, $n, $cxt) = @_;
+ $cxt = SUB unless defined $cxt;
+ if ($n) {
+ bonk($code, $n - 1, $cxt);
+ } else {
+ &uplevel($code, $cxt);
+ }
+}
+
+{
+ my $desc = "an exception unwinding several levels of the same sub 1";
+ local $@;
+ check_depth \&bonk, 0, "$desc: depth at the beginning";
+ my $rec = 7;
+ sub {
+ eval {
+ bonk(sub {
+ check_depth \&bonk, $rec + 1, "$desc: depth inside";
+ die 'pepperoni';
+ }, $rec);
+ }
+ }->();
+ my $line = __LINE__-4;
+ like $@, qr/^pepperoni at \Q$0\E line $line/, "$desc: correct exception";
+ check_depth \&bonk, 0, "$desc: depth at the end";
+}
+
+sub clash {
+ my ($pre, $rec, $desc, $cxt, $m, $n) = @_;
+ $m = 0 unless defined $m;
+ if ($m < $pre) {
+ clash($pre, $rec, $desc, $cxt, $m + 1, $n);
+ } elsif ($m == $pre) {
+ check_depth \&clash, $pre + 1, "$desc: depth after prepending frames";
+ eval {
+ clash($pre, $rec, $desc, $cxt, $pre + 1, $n);
+ };
+ my $line = __LINE__+11;
+ like $@, qr/^garlic at \Q$0\E line $line/, "$desc: correct exception";
+ check_depth \&clash, $pre + 1, "$desc: depth after unwinding";
+ } else {
+ $n = 0 unless defined $n;
+ $cxt = SUB unless defined $cxt;
+ if ($n < $rec) {
+ clash($pre, $rec, $desc, $cxt, $m, $n + 1);
+ } else {
+ uplevel {
+ check_depth \&clash, $pre + 1 + $rec + 1, "$desc: depth inside";
+ die 'garlic';
+ } $cxt;
+ }
+ }
+}
+
+{
+ my $desc = "an exception unwinding several levels of the same sub 2";
+ local $@;
+ check_depth \&clash, 0, "$desc: depth at the beginning";
+ my $pre = 5;
+ my $rec = 10;
+ sub {
+ eval {
+ clash($pre, $rec, $desc);
+ }
+ }->();
+ is $@, '', "$desc: no exception outside";
+ check_depth \&clash, 0, "$desc: depth at the beginning";
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => ((3 * 4) / 2) * 2 * 2 + 8;
+
+use Scope::Upper qw<uplevel HERE CALLER>;
+
+sub callstack {
+ my ($check_args) = @_;
+ my $i = 1;
+ my @stack;
+ while (1) {
+ my @c = $check_args ? do { package DB; caller($i++) }
+ : caller($i++);
+ last unless @c;
+ if ($check_args) {
+ my $args = $c[4] ? [ @DB::args ] : undef;
+ push @c, $args;
+ }
+ push @stack, \@c;
+ }
+ return \@stack;
+}
+
+my @stacks;
+
+sub three {
+ my ($depth, $code) = @_;
+ $stacks[0] = callstack(1);
+ &uplevel($code, 'three', CALLER($depth));
+}
+
+my $two = sub {
+ $stacks[1] = callstack(1);
+ three(@_, 'two');
+};
+
+sub one {
+ $stacks[2] = callstack(1);
+ $two->(@_, 'one');
+}
+
+sub tester_sub { callstack(1) }
+
+my $tester_anon = sub { callstack(1) };
+
+my @subs = (\&three, $two, \&one);
+
+for my $height (0 .. 2) {
+ my $base = $subs[$height];
+
+ for my $anon (0, 1) {
+ my $code = $anon ? $tester_anon : \&tester_sub;
+
+ for my $depth (0 .. $height) {
+ my $desc = "callstack at depth $depth/$height";
+ $desc .= $anon ? ' (anonymous callback)' : ' (named callback)';
+
+ local $@;
+ my $result = eval { $base->($depth, $code, 'zero') };
+ is $@, '', "$desc: no error";
+ is_deeply $result, $stacks[$depth], "$desc: correct call stack";
+ }
+ }
+}
+
+sub four {
+ my $cb = shift;
+ &uplevel($cb, 1, HERE);
+}
+
+{
+ my $desc = "recalling in the coderef passed to uplevel (anonymous)";
+ my $cb;
+ $cb = sub { $_[0] ? $cb->(0) : callstack(0) };
+ local $@;
+ my ($expected, $got) = eval { $cb->(1), four($cb) };
+ is $@, '', "$desc: no error";
+ $expected->[1]->[3] = 'main::four';
+ is_deeply $got, $expected, "$desc: correct call stack";
+}
+
+sub test_named_recall { $_[0] ? test_named_recall(0) : callstack(0) }
+
+{
+ my $desc = "recalling in the coderef passed to uplevel (named)";
+ local $@;
+ my ($expected, $got) = eval { test_named_recall(1),four(\&test_named_recall) };
+ is $@, '', "$desc: no error";
+ $expected->[1]->[3] = 'main::four';
+ is_deeply $got, $expected, "$desc: correct call stack";
+}
+
+my $mixed_recall_1;
+sub test_mixed_recall_1 {
+ if ($_[0]) {
+ $mixed_recall_1->(0)
+ } else {
+ callstack(0)
+ }
+}
+$mixed_recall_1 = \&test_mixed_recall_1;
+
+{
+ my $desc = "recalling in the coderef passed to uplevel (mixed 1)";
+ local $@;
+ my ($expected, $got) = eval { test_mixed_recall_1(1), four($mixed_recall_1) };
+ is $@, '', "$desc: no error";
+ $expected->[1]->[3] = 'main::four';
+ is_deeply $got, $expected, "$desc: correct call stack";
+}
+
+my $mixed_recall_2_bis = do {
+ my $mixed_recall_2;
+
+ {
+ my $fake1;
+
+ eval q{
+ my $fake2;
+
+ {
+ my $fake3;
+
+ sub test_mixed_recall_2 {
+ $fake1++;
+ $fake2++;
+ $fake3++;
+ if ($_[0]) {
+ $mixed_recall_2->(0)
+ } else {
+ callstack(0)
+ }
+ }
+ }
+ };
+ }
+
+ $mixed_recall_2 = \&test_mixed_recall_2;
+};
+
+{
+ my $desc = "recalling in the coderef passed to uplevel (mixed 2)";
+ local $@;
+ my ($expected, $got) = eval { test_mixed_recall_2(1), four($mixed_recall_2_bis) };
+ is $@, '', "$desc: no error";
+ $expected->[1]->[3] = 'main::four';
+ is_deeply $got, $expected, "$desc: correct call stack";
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 3 + 7 * 2 + 8;
+
+use Scope::Upper qw<uplevel HERE UP>;
+
+sub depth {
+ my $depth = 0;
+ while (1) {
+ my @c = caller($depth);
+ last unless @c;
+ ++$depth;
+ }
+ return $depth - 1;
+}
+
+is depth(), 0, 'check top depth';
+is sub { depth() }->(), 1, 'check subroutine call depth';
+is do { local $@; eval { depth() } }, 1, 'check eval block depth';
+
+{
+ my $desc = 'uplevel in uplevel : lower frame';
+ local $@;
+ my @ret = eval {
+ 1, sub {
+ is depth(), 2, "$desc: correct depth 1";
+ 2, uplevel(sub {
+ is depth(), 2, "$desc: correct depth 2";
+ 3, sub {
+ is depth(), 3, "$desc: correct depth 3";
+ 4, uplevel(sub {
+ is depth(), 3, "$desc: correct depth 4";
+ return 5, @_;
+ }, 6, @_, HERE);
+ }->(7, @_);
+ }, 8, @_, HERE);
+ }->(9);
+ };
+ is $@, '', "$desc: no error";
+ is depth(), 0, "$desc: correct depth outside";
+ is_deeply \@ret, [ 1 .. 9 ], "$desc: correct return value"
+}
+
+{
+ my $desc = 'uplevel in uplevel : same frame';
+ local $@;
+ my @ret = eval {
+ 11, sub {
+ is depth(), 2, "$desc: correct depth 1";
+ 12, uplevel(sub {
+ is depth(), 2, "$desc: correct depth 2";
+ 13, sub {
+ is depth(), 3, "$desc: correct depth 3";
+ 14, uplevel(sub {
+ is depth(), 2, "$desc: correct depth 4";
+ return 15, @_;
+ }, 16, @_, UP);
+ }->(17, @_);
+ }, 18, @_, HERE);
+ }->(19);
+ };
+ is $@, '', "$desc: no error";
+ is depth(), 0, "$desc: correct depth outside";
+ is_deeply \@ret, [ 11 .. 19 ], "$desc: correct return value"
+}
+
+{
+ my $desc = 'uplevel in uplevel : higher frame';
+ local $@;
+ my @ret = eval {
+ 20, sub {
+ is depth(), 2, "$desc: correct depth 1";
+ 21, sub {
+ is depth(), 3, "$desc: correct depth 2";
+ 22, uplevel(sub {
+ is depth(), 3, "$desc: correct depth 3";
+ 23, sub {
+ is depth(), 4, "$desc: correct depth 4";
+ 24, uplevel(sub {
+ is depth(), 2, "$desc: correct depth 5";
+ return 25, @_;
+ }, 26, @_, UP UP);
+ }->(27, @_);
+ }, 28, @_, HERE);
+ }->(29, @_);
+ }->('2A');
+ };
+ is $@, '', "$desc: no error";
+ is depth(), 0, "$desc: correct depth outside";
+ is_deeply \@ret, [ 20 .. 29, '2A' ], "$desc: correct return value"
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+
+use Scope::Upper qw<uplevel UP>;
+
+{
+ my $want;
+ my @res = sub {
+ uplevel {
+ $want = wantarray;
+ };
+ return;
+ }->();
+ is $want, undef, 'static void context';
+}
+
+{
+ my $want;
+ my @res = sub {
+ my $res = uplevel {
+ $want = wantarray;
+ };
+ return;
+ }->();
+ is $want, '', 'static scalar context';
+}
+
+{
+ my $want;
+ my $res = sub {
+ my @res = uplevel {
+ $want = wantarray;
+ };
+ return;
+ }->();
+ is $want, 1, 'static list context';
+}
+
+{
+ my $want;
+ my @res = sub {
+ sub {
+ uplevel {
+ $want = wantarray;
+ } UP;
+ }->();
+ return;
+ }->();
+ is $want, undef, 'dynamic void context';
+}
+
+{
+ my $want;
+ my @res = sub {
+ my $res = sub {
+ uplevel {
+ $want = wantarray;
+ } UP;
+ }->();
+ return;
+ }->();
+ is $want, '', 'dynamic scalar context';
+}
+
+{
+ my $want;
+ my $res = sub {
+ my @res = sub {
+ uplevel {
+ $want = wantarray;
+ } UP;
+ }->();
+ return;
+ }->();
+ is $want, 1, 'dynamic list context';
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+
+use Scope::Upper qw<uplevel HERE UP>;
+
+{
+ our $x = 1;
+ sub {
+ local $x = 2;
+ sub {
+ local $x = 3;
+ uplevel { is $x, 3, 'global variables scoping 1' } HERE;
+ }->();
+ }->();
+}
+
+{
+ our $x = 4;
+ sub {
+ local $x = 5;
+ sub {
+ local $x = 6;
+ uplevel { is $x, 6, 'global variables scoping 2' } UP;
+ }->();
+ }->();
+}
+
+sub {
+ "abc" =~ /(.)/;
+ sub {
+ "xyz" =~ /(.)/;
+ uplevel { is $1, 'x', 'match variables scoping 1' } HERE;
+ }->();
+}->();
+
+sub {
+ "abc" =~ /(.)/;
+ sub {
+ "xyz" =~ /(.)/;
+ uplevel { is $1, 'x', 'match variables scoping 2' } UP;
+ }->();
+}->();
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+sub skipall {
+ my ($msg) = @_;
+ require Test::More;
+ Test::More::plan(skip_all => $msg);
+}
+
+use Config qw<%Config>;
+
+BEGIN {
+ my $force = $ENV{PERL_SCOPE_UPPER_TEST_THREADS} ? 1 : !1;
+ my $t_v = $force ? '0' : '1.67';
+ skipall 'This perl wasn\'t built to support threads'
+ unless $Config{useithreads};
+ skipall 'perl 5.13.4 required to test thread safety'
+ unless $force or "$]" >= 5.013004;
+ skipall "threads $t_v required to test thread safety"
+ unless eval "use threads $t_v; 1";
+}
+
+use Test::More;
+
+use Scope::Upper qw<uplevel UP SU_THREADSAFE>;
+
+my $num;
+
+BEGIN {
+ skipall 'This Scope::Upper isn\'t thread safe' unless SU_THREADSAFE;
+ plan tests => 3 + ($num = 30) * 3;
+ defined and diag "Using threads $_" for $threads::VERSION;
+ if (eval "use Time::HiRes; 1") {
+ defined and diag "Using Time::HiRes $_" for $Time::HiRes::VERSION;
+ *usleep = \&Time::HiRes::usleep;
+ } else {
+ diag 'Using fallback usleep';
+ *usleep = sub {
+ my $s = int($_[0] / 2.5e5);
+ sleep $s if $s;
+ };
+ }
+}
+
+sub depth {
+ my $depth = 0;
+ while (1) {
+ my @c = caller($depth);
+ last unless @c;
+ ++$depth;
+ }
+ return $depth - 1;
+}
+
+is depth(), 0, 'check top depth';
+is sub { depth() }->(), 1, 'check subroutine call depth';
+is do { local $@; eval { depth() } }, 1, 'check eval block depth';
+
+our $z;
+
+sub cb {
+ my $d = splice @_, 1, 1;
+ my $p = shift;
+ my $tid = pop;
+ is depth(), $d - 1, "$p: correct depth inside";
+ $tid, @_, $tid + 2
+}
+
+sub up1 {
+ my $tid = threads->tid();
+ local $z = $tid;
+ my $p = "[$tid] up1";
+
+ usleep rand(1e6);
+
+ my @res = (
+ -2,
+ sub {
+ my @dummy = (
+ -1,
+ sub {
+ my $d = depth();
+ my @ret = &uplevel(\&cb => ($p, $d, $tid + 1, $tid) => UP);
+ is depth(), $d, "$p: correct depth after uplevel";
+ @ret;
+ }->(),
+ 1
+ );
+ }->(),
+ 2
+ );
+
+ is_deeply \@res, [ -2, -1, $tid .. $tid + 2, 1, 2 ], "$p: returns correctly";
+}
+
+$_->join for map threads->create(\&up1), 1 .. $num;
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use lib 't/lib';
+use Test::Leaner;
+
+use Scope::Upper qw<uplevel HERE UP SUB CALLER>;
+
+my $n = 1_000;
+
+plan tests => 3 + $n * (6 + 3);
+
+my $period1 = 100;
+my $period2 = 10;
+my $shift = 10;
+my $amp = 10;
+
+sub PI () { CORE::atan2(0, -1) }
+
+sub depth {
+ my $depth = 0;
+ while (1) {
+ my @c = caller($depth);
+ last unless @c;
+ ++$depth;
+ }
+ return $depth - 1;
+}
+
+sub cap {
+ my ($depth, $top) = @_;
+
+ $depth <= 0 ? 1
+ : $depth >= $top ? $top - 1
+ : $depth;
+}
+
+sub base_depth {
+ cap($shift + int($amp * sin(2 * PI * $_[0] / $period1)), 2 * $shift + 1);
+}
+
+sub uplevel_depth {
+ my ($base_depth, $i) = @_;
+
+ my $h = int($base_depth / 2);
+
+ cap($h + int($h * sin(2 * PI * $i / $period2)), $base_depth);
+}
+
+sub rec_basic {
+ my ($base_depth, $uplevel_depth, $desc, $i) = @_;
+ if ($i < $base_depth) {
+ $i, rec_basic($base_depth, $uplevel_depth, $desc, $i + 1);
+ } else {
+ is depth(), $base_depth+1, "$desc: depth before uplevel";
+ my $ret = uplevel {
+ is depth(), $base_depth+1-$uplevel_depth, "$desc: depth inside uplevel";
+ is "@_", "$base_depth $uplevel_depth", "$desc: arguments";
+ -$uplevel_depth;
+ } @_[0, 1], CALLER($uplevel_depth);
+ is depth(), $base_depth+1, "$desc: depth after uplevel";
+ $ret;
+ }
+}
+
+sub rec_die {
+ my ($base_depth, $uplevel_depth, $desc, $i) = @_;
+ if ($i < $base_depth) {
+ local $@;
+ my $ret;
+ if ($i % 2) {
+ $ret = eval q<
+ rec_die($base_depth, $uplevel_depth, $desc, $i + 1)
+ >
+ } else {
+ $ret = eval {
+ rec_die($base_depth, $uplevel_depth, $desc, $i + 1)
+ }
+ }
+ return $@ ? $@
+ : $ret ? $ret
+ : undef;
+ } else {
+ my $cxt = SUB;
+ {
+ my $n = $uplevel_depth;
+ while ($n) {
+ $cxt = SUB UP $cxt;
+ $n--;
+ }
+ }
+ my $ret = uplevel {
+ is HERE, $cxt, "$desc: context inside uplevel";
+ die "XXX @_";
+ } @_[0, 1], $cxt;
+ $ret;
+ }
+}
+
+my $die_line = __LINE__-6;
+
+is depth(), 0, 'check top depth';
+is sub { depth() }->(), 1, 'check subroutine call depth';
+is do { local $@; eval { depth() } }, 1, 'check eval block depth';
+
+for my $i (1 .. $n) {
+ my $base_depth = base_depth($i);
+ my $uplevel_depth = uplevel_depth($base_depth, $i);
+
+ {
+ my $desc = "basic $base_depth $uplevel_depth";
+
+ my @ret = rec_basic($base_depth, $uplevel_depth, $desc, 0);
+ is depth(), 0, "$desc: depth outside";
+ is_deeply \@ret, [ 0 .. $base_depth-1, -$uplevel_depth ],
+ "$desc: returned values";
+ }
+
+ {
+ ++$base_depth;
+ my $desc = "die $base_depth $uplevel_depth";
+
+ my $err = rec_die($base_depth, $uplevel_depth, $desc, 0);
+ is depth(), 0, "$desc: depth outside";
+ like $err, qr/^XXX $base_depth $uplevel_depth at \Q$0\E line $die_line/,
+ "$desc: correct error";
+ }
+}
projects / perl / modules / Scope-Upper.git / commitdiff