t/51-unwind-multi.t
t/52-unwind-context.t
t/54-unwind-threads.t
+t/55-yield-target.t
+t/57-yield-context.t
+t/58-yield-misc.t
+t/59-yield-threads.t
t/60-uplevel-target.t
t/61-uplevel-args.t
t/62-uplevel-return.t
t/79-uid-threads.t
t/81-stress-level.t
t/84-stress-unwind.t
+t/85-stress-yield.t
t/86-stress-uplevel.t
t/87-stress-uid.t
t/91-pod.t
OP proxy_op;
} su_unwind_storage;
+/* --- yield() global storage ---------------------------------------------- */
+
+typedef struct {
+ I32 cxix;
+ I32 items;
+ SV **savesp;
+ UNOP leave_op;
+ OP proxy_op;
+} su_yield_storage;
+
/* --- uplevel() data tokens and global storage ---------------------------- */
#define SU_UPLEVEL_HIJACKS_RUNOPS SU_HAS_PERL(5, 8, 0)
typedef struct {
char *stack_placeholder;
su_unwind_storage unwind_storage;
+ su_yield_storage yield_storage;
su_uplevel_storage uplevel_storage;
su_uid_storage uid_storage;
} my_cxt_t;
/* --- Pop a context back -------------------------------------------------- */
-#if SU_DEBUG
-# ifdef DEBUGGING
-# define SU_CXNAME(C) PL_block_type[CxTYPE(C)]
-# else
-# define SU_CXNAME(C) "XXX"
-# endif
+#if SU_DEBUG && defined(DEBUGGING)
+# define SU_CXNAME(C) PL_block_type[CxTYPE(C)]
+#else
+# define SU_CXNAME(C) "XXX"
#endif
STATIC void su_pop(pTHX_ void *ud) {
PL_op = &(MY_CXT.unwind_storage.proxy_op);
}
+/* --- Yield --------------------------------------------------------------- */
+
+#if SU_HAS_PERL(5, 10, 0)
+# define SU_RETOP_SUB(C) ((C)->blk_sub.retop)
+# define SU_RETOP_EVAL(C) ((C)->blk_eval.retop)
+# define SU_RETOP_LOOP(C) ((C)->blk_loop.my_op->op_lastop->op_next)
+# define SU_RETOP_GIVEN(C) ((C)->blk_givwhen.leave_op->op_next)
+#else
+# define SU_RETOP_SUB(C) ((C)->blk_oldretsp > 0 ? PL_retstack[(C)->blk_oldretsp - 1] : NULL)
+# define SU_RETOP_EVAL(C) SU_RETOP_SUB(C)
+# define SU_RETOP_LOOP(C) ((C)->blk_loop.last_op->op_next)
+#endif
+
+STATIC void su_yield(pTHX_ void *ud_) {
+ dMY_CXT;
+ PERL_CONTEXT *cx;
+ I32 cxix = MY_CXT.yield_storage.cxix;
+ I32 items = MY_CXT.yield_storage.items - 1;
+ SV **savesp = MY_CXT.yield_storage.savesp;
+ opcode type = OP_NULL;
+ U8 flags = 0;
+ OP *next;
+
+ PERL_UNUSED_VAR(ud_);
+
+ if (savesp)
+ PL_stack_sp = savesp;
+
+ cx = cxstack + cxix;
+ switch (CxTYPE(cx)) {
+ case CXt_BLOCK: {
+ I32 i, cur = cxstack_ix, n = 1;
+ OP *o = NULL;
+ /* Is this actually a given/when block? This may occur only when yield was
+ * called with HERE (or nothing) as the context. */
+#if SU_HAS_PERL(5, 10, 0)
+ if (cxix > 0) {
+ PERL_CONTEXT *prev = cx - 1;
+ U8 type = CxTYPE(prev);
+ if ((type == CXt_GIVEN || type == CXt_WHEN)
+ && (prev->blk_oldcop == cx->blk_oldcop)) {
+ cxix--;
+ cx = prev;
+ if (type == CXt_GIVEN)
+ goto cxt_given;
+ else
+ goto cxt_when;
+ }
+ }
+#endif
+ type = OP_LEAVE;
+ next = NULL;
+ /* Bare blocks (that appear as do { ... } blocks, map { ... } blocks or
+ * constant folded blcoks) don't need to save the op to return to anywhere
+ * since 'last' isn't supposed to work inside them. So we climb higher in
+ * the context stack until we reach a context that has a return op (i.e. a
+ * sub, an eval, a format or a real loop), recording how many blocks we
+ * crossed. Then we follow the op_next chain until we get to the leave op
+ * that closes the original block, which we are assured to reach since
+ * everything is static (the blocks we have crossed cannot be evals or
+ * subroutine calls). */
+ for (i = cxix + 1; i <= cur; ++i) {
+ PERL_CONTEXT *cx2 = cxstack + i;
+ switch (CxTYPE(cx2)) {
+ case CXt_BLOCK:
+ ++n;
+ break;
+ case CXt_SUB:
+ case CXt_FORMAT:
+ o = SU_RETOP_SUB(cx2);
+ break;
+ case CXt_EVAL:
+ o = SU_RETOP_EVAL(cx2);
+ break;
+#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
+ o = SU_RETOP_LOOP(cx2);
+ break;
+ }
+ if (o)
+ break;
+ }
+ if (!o)
+ o = PL_op;
+ while (n && o) {
+ /* We may find other enter/leave blocks on our way to the matching leave.
+ * Make sure the depth is incremented/decremented appropriately. */
+ if (o->op_type == OP_ENTER) {
+ ++n;
+ } else if (o->op_type == OP_LEAVE) {
+ --n;
+ if (!n) {
+ next = o->op_next;
+ break;
+ }
+ }
+ o = o->op_next;
+ }
+ break;
+ }
+ case CXt_SUB:
+ case CXt_FORMAT:
+ type = OP_LEAVESUB;
+ next = SU_RETOP_SUB(cx);
+ break;
+ case CXt_EVAL:
+ type = CxTRYBLOCK(cx) ? OP_LEAVETRY : OP_LEAVEEVAL;
+ next = SU_RETOP_EVAL(cx);
+ break;
+#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
+ type = OP_LEAVELOOP;
+ next = SU_RETOP_LOOP(cx);
+ break;
+#if SU_HAS_PERL(5, 10, 0)
+ case CXt_GIVEN:
+cxt_given:
+ type = OP_LEAVEGIVEN;
+ next = SU_RETOP_GIVEN(cx);
+ break;
+ case CXt_WHEN:
+cxt_when:
+#if SU_HAS_PERL(5, 15, 1)
+ type = OP_LEAVEWHEN;
+#else
+ type = OP_BREAK;
+ flags |= OPf_SPECIAL;
+#endif
+ next = NULL;
+ break;
+#endif
+ case CXt_SUBST:
+ croak("yield() cannot target a substitution context");
+ break;
+ default:
+ croak("yield() don't know how to leave a %s context", SU_CXNAME(cxstack + cxix));
+ break;
+ }
+
+ if (cxstack_ix > cxix)
+ dounwind(cxix);
+
+ /* Hide the level */
+ if (items >= 0)
+ PL_stack_sp--;
+ else
+ items = 0;
+
+ /* Copy the arguments passed to yield() where the leave op expects to find
+ * them. */
+ if (items)
+ Move(PL_stack_sp - items + 1, PL_stack_base + cx->blk_oldsp + 1, items, SV *);
+ PL_stack_sp = PL_stack_base + cx->blk_oldsp + items;
+
+ flags |= OP_GIMME_REVERSE(cx->blk_gimme);
+
+ MY_CXT.yield_storage.leave_op.op_type = type;
+ MY_CXT.yield_storage.leave_op.op_ppaddr = PL_ppaddr[type];
+ MY_CXT.yield_storage.leave_op.op_flags = flags;
+ MY_CXT.yield_storage.leave_op.op_next = next;
+
+ PL_op = (OP *) &(MY_CXT.yield_storage.leave_op);
+ PL_op = PL_op->op_ppaddr(aTHX);
+
+ MY_CXT.yield_storage.proxy_op.op_next = PL_op;
+ PL_op = &(MY_CXT.yield_storage.proxy_op);
+}
+
/* --- Uplevel ------------------------------------------------------------- */
#define SU_UPLEVEL_SAVE(f, t) STMT_START { sud->old_##f = PL_##f; PL_##f = (t); } STMT_END
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;
croak("Can't return outside a subroutine");
}
+XS(XS_Scope__Upper_yield); /* prototype to pass -Wmissing-prototypes */
+
+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;
+ /* See XS_Scope__Upper_unwind */
+ if (GIMME_V == G_SCALAR) {
+ MY_CXT.yield_storage.savesp = PL_stack_sp;
+ PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
+ } else {
+ MY_CXT.yield_storage.savesp = NULL;
+ }
+ SAVEDESTRUCTOR_X(su_yield, NULL);
+ return;
+}
+
MODULE = Scope::Upper PACKAGE = Scope::Upper
PROTOTYPES: ENABLE
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);
su_setup();
}
=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 L</yield>, and know which context was in use then with L</want_at> ;
=item *
will set C<$num> to C<'z'>.
You can use L</want_at> to handle these cases.
+=head2 C<yield>
+
+ yield;
+ yield @values, $context;
+
+Returns C<@values> I<from> the context pointed by or just above C<$context>, and immediately restart the program flow at this point.
+If C<@values> is empty, then the C<$context> parameter is optional and defaults to the current context ; otherwise it is mandatory.
+
+L</yield> differs from L</unwind> in that it can target I<any> upper scope (besides a C<s///e> substitution context) and not necessarily a sub, an eval or a format.
+Hence you can use it to return values from a C<do> or a C<map> block :
+
+ my $now = do {
+ local $@;
+ eval { require Time::HiRes } or yield time() => HERE;
+ Time::HiRes::time();
+ };
+
+ my @uniq = map {
+ yield if $seen{$_}++; # returns the empty list from the block
+ ...
+ } @things;
+
+Like for L</unwind>, the upper context isn't coerced onto C<@values>.
+
=head2 C<want_at>
my $want = want_at;
# $cxt = SCOPE(4), UP SUB UP SUB = UP SUB EVAL = UP CALLER(2) = TOP
...
-Where L</unwind>, L</want_at> and L</uplevel> point to depending on the C<$cxt>:
+Where L</unwind>, L</yield>, L</want_at> and L</uplevel> point to depending on the C<$cxt>:
sub {
eval {
sub {
{
- unwind @things => $cxt; # or uplevel { ... } $cxt;
+ unwind @things => $cxt; # or yield @things => $cxt
+ # or uplevel { ... } $cxt
...
}
...
=head1 EXPORT
-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 functions L</reap>, L</localize>, L</localize_elem>, L</localize_delete>, L</unwind>, L</yield>, 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'>.
funcs => [ qw<
reap
localize localize_elem localize_delete
- unwind want_at
+ unwind yield
+ want_at
uplevel
uid validate_uid
> ],
use strict;
use warnings;
-use Test::More tests => 2 * 17;
+use Test::More tests => 2 * 18;
require Scope::Upper;
localize_elem => '$$$;$',
localize_delete => '$$;$',
unwind => undef,
+ yield => undef,
want_at => ';$',
uplevel => '&@',
uid => ';$',
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 18;
+
+use Scope::Upper qw<yield>;
+
+my @res;
+
+@res = (0, eval {
+ yield;
+ 1;
+}, 2);
+is $@, '', 'yield() does not croak';
+is_deeply \@res, [ 0, 2 ], 'yield() in eval { ... }';
+
+@res = (3, eval "
+ yield;
+ 4;
+", 5);
+is $@, '', 'yield() does not croak';
+is_deeply \@res, [ 3, 5 ], 'yield() in eval "..."';
+
+@res = (6, sub {
+ yield;
+ 7;
+}->(), 8);
+is_deeply \@res, [ 6, 8 ], 'yield() in sub { ... }';
+
+@res = (9, do {
+ yield;
+ 10;
+}, 11);
+is_deeply \@res, [ 9, 11 ], 'yield() in do { ... }';
+
+@res = (12, (map {
+ yield;
+ 13;
+} qw<a b c>), 14);
+is_deeply \@res, [ 12, 14 ], 'yield() in map { ... }';
+
+my $loop;
+@res = (15, do {
+ for (16, 17) {
+ $loop = $_;
+ yield;
+ my $x = 18;
+ }
+}, 19);
+is $loop, 16, 'yield() exited for';
+is_deeply \@res, [ 15, 19 ], 'yield() in for () { ... }';
+
+@res = (20, do {
+ $loop = 21;
+ while ($loop) {
+ yield;
+ $loop = 0;
+ my $x = 22;
+ }
+}, 23);
+is $loop, 21, 'yield() exited while';
+is_deeply \@res, [ 20, 23 ], 'yield() in while () { ... }';
+
+{
+ my $s = 'a';
+ local $@;
+ eval {
+ $s =~ s/./yield; die 'not reached'/e;
+ };
+ my $err = $@;
+ my $line = __LINE__-3;
+ like $err,
+ qr/^yield\(\) cannot target a substitution context at \Q$0\E line $line/,
+ 'yield() cannot exit subst';
+}
+
+SKIP: {
+ skip 'perl 5.10 is required to test interaction with given/when' => 6
+ if "$]" < 5.010;
+
+ @res = eval <<'TESTCASE';
+ use feature 'switch';
+ (24, do {
+ given (25) {
+ yield;
+ my $x = 26;
+ }
+ }, 27);
+TESTCASE
+ diag $@ if $@;
+ is_deeply \@res, [ 24, 27 ], 'yield() in given { }';
+
+ # Beware that calling yield() in when() in given() sends us directly at the
+ # end of the enclosing given block.
+ @res = ();
+ eval <<'TESTCASE';
+ use feature 'switch';
+ @res = (28, do {
+ given (29) {
+ when (29) {
+ yield;
+ die 'not reached 1';
+ }
+ die 'not reached 2';
+ }
+ }, 30)
+TESTCASE
+ is $@, '', 'yield() in when { } in given did not croak';
+ is_deeply \@res, [ 28, 30 ], 'yield() in when { } in given';
+
+ # But calling yield() in when() in for() sends us at the next iteration.
+ @res = ();
+ eval <<'TESTCASE';
+ use feature 'switch';
+ @res = (31, do {
+ for (32, 33) {
+ $loop = $_;
+ when (32) {
+ yield;
+ die 'not reached 3';
+ my $x = 34;
+ }
+ when (33) {
+ yield;
+ die 'not reached 4';
+ my $x = 35;
+ }
+ die 'not reached 5';
+ my $x = 36;
+ }
+ }, 37)
+TESTCASE
+ is $@, '', 'yield() in for { } in given did not croak';
+ is $loop, 33, 'yield() exited for on the second iteration';
+ # A loop exited by last() evaluates to an empty list, but a loop that reached
+ # its natural end evaluates to false!
+ is_deeply \@res, [ 31, '', 37 ], 'yield() in when { }';
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 33;
+
+use Scope::Upper qw<yield HERE SCOPE SUB>;
+
+my ($res, @res);
+
+# --- Void to void ------------------------------------------------------------
+
+do {
+ $res = 1;
+ yield(qw<a b c> => HERE);
+ $res = 0;
+};
+ok $res, 'yield in void context at sub to void';
+
+do {
+ $res = 1;
+ eval {
+ yield(qw<d e f> => SCOPE(1));
+ };
+ $res = 0;
+};
+ok $res, 'yield in void context at sub across eval to void';
+
+do {
+ $res = 1;
+ for (1 .. 5) {
+ yield qw<g h i> => SCOPE(1);
+ }
+ $res = 0;
+};
+ok $res, 'yield in void context at sub across loop to void';
+
+# --- Void to scalar ----------------------------------------------------------
+
+$res = do {
+ yield(qw<a b c> => HERE);
+ return 'XXX';
+};
+is $res, 'c', 'yield in void context at sub to scalar';
+
+$res = do {
+ eval {
+ yield qw<d e f> => SCOPE(1);
+ };
+ return 'XXX';
+};
+is $res, 'f', 'yield in void context at sub across eval to scalar';
+
+$res = do {
+ for (1 .. 5) {
+ yield qw<g h i> => SCOPE(1);
+ }
+};
+is $res, 'i', 'yield in void context at sub across loop to scalar';
+
+$res = do {
+ for (6, yield qw<j k l> => SCOPE(0)) {
+ $res = 'NO';
+ }
+ 'XXX';
+};
+is $res, 'l', 'yield in void context at sub across loop iterator to scalar';
+
+# --- Void to list ------------------------------------------------------------
+
+@res = do {
+ yield qw<a b c> => HERE;
+ return 'XXX';
+};
+is_deeply \@res, [ qw<a b c> ], 'yield in void context at sub to list';
+
+@res = do {
+ eval {
+ yield qw<d e f> => SCOPE(1);
+ };
+ 'XXX';
+};
+is_deeply \@res, [ qw<d e f> ], 'yield in void context at sub across eval to list';
+
+@res = do {
+ for (1 .. 5) {
+ yield qw<g h i> => SCOPE(1);
+ }
+};
+is_deeply \@res, [ qw<g h i> ], 'yield in void context at sub across loop to list';
+
+# --- Scalar to void ----------------------------------------------------------
+
+do {
+ $res = 1;
+ my $temp = yield(qw<a b c> => HERE);
+ $res = 0;
+};
+ok $res, 'yield in scalar context at sub to void';
+
+do {
+ $res = 1;
+ my $temp = eval {
+ yield(qw<d e f> => SCOPE(1));
+ };
+ $res = 0;
+};
+ok $res, 'yield in scalar context at sub across eval to void';
+
+do {
+ $res = 1;
+ for (1 .. 5) {
+ my $temp = (yield qw<g h i> => SCOPE(1));
+ }
+ $res = 0;
+};
+ok $res, 'yield in scalar context at sub across loop to void';
+
+do {
+ $res = 1;
+ if (yield qw<m n o> => SCOPE(0)) {
+ $res = undef;
+ }
+ $res = 0;
+};
+ok $res, 'yield in scalar context at sub across test to void';
+
+# --- Scalar to scalar --------------------------------------------------------
+
+$res = sub {
+ 1, yield(qw<a b c> => HERE);
+}->(0);
+is $res, 'c', 'yield in scalar context at sub to scalar';
+
+$res = sub {
+ eval {
+ 8, yield qw<d e f> => SCOPE(1);
+ };
+}->(0);
+is $res, 'f', 'yield in scalar context at sub across eval to scalar';
+
+$res = sub {
+ if (yield qw<m n o> => SCOPE(0)) {
+ return 'XXX';
+ }
+}->(0);
+is $res, 'o', 'yield in scalar context at sub across test to scalar';
+
+# --- Scalar to list ----------------------------------------------------------
+
+@res = sub {
+ if (yield qw<m n o> => SCOPE(0)) {
+ return 'XXX';
+ }
+}->(0);
+is_deeply \@res, [ qw<m n o> ], 'yield in scalar context at sub across test to list';
+
+# --- List to void ------------------------------------------------------------
+
+do {
+ $res = 1;
+ my @temp = yield(qw<a b c> => HERE);
+ $res = 0;
+};
+ok $res, 'yield in list context at sub to void';
+
+do {
+ $res = 1;
+ my @temp = eval {
+ yield(qw<d e f> => SCOPE(1));
+ };
+ $res = 0;
+};
+ok $res, 'yield in list context at sub across eval to void';
+
+do {
+ $res = 1;
+ for (1 .. 5) {
+ my @temp = (yield qw<g h i> => SCOPE(1));
+ }
+ $res = 0;
+};
+ok $res, 'yield in list context at sub across loop to void';
+
+do {
+ $res = 1;
+ for (6, yield qw<j k l> => SCOPE(0)) {
+ $res = undef;
+ }
+ $res = 0;
+};
+ok $res, 'yield in list context at sub across test to void';
+
+# --- List to scalar ----------------------------------------------------------
+
+$res = do {
+ my @temp = (1, yield(qw<a b c> => HERE));
+ 'XXX';
+};
+is $res, 'c', 'yield in list context at sub to scalar';
+
+$res = do {
+ my @temp = eval {
+ 8, yield qw<d e f> => SCOPE(1);
+ };
+ 'XXX';
+};
+is $res, 'f', 'yield in list context at sub across eval to scalar';
+
+$res = do {
+ for (1 .. 5) {
+ my @temp = (7, yield qw<g h i> => SCOPE(1));
+ }
+ 'XXX';
+};
+is $res, 'i', 'yield in list context at sub across loop to scalar';
+
+$res = sub {
+ for (6, yield qw<j k l> => SCOPE(0)) {
+ return 'XXX';
+ }
+}->(0);
+is $res, 'l', 'yield in list context at sub across loop iterator to scalar';
+
+# --- List to list ------------------------------------------------------------
+
+@res = do {
+ 2, yield qw<a b c> => HERE;
+};
+is_deeply \@res, [ qw<a b c> ], 'yield in list context at sub to list';
+
+@res = do {
+ eval {
+ 8, yield qw<d e f> => SCOPE(1);
+ };
+};
+is_deeply \@res, [ qw<d e f> ], 'yield in list context at sub across eval to list';
+
+@res = sub {
+ for (6, yield qw<j k l> => SCOPE(0)) {
+ return 'XXX';
+ }
+}->(0);
+is_deeply \@res, [ qw<j k l> ], 'yield in list context at sub across loop iterator to list';
+
+# --- Prototypes --------------------------------------------------------------
+
+sub pie { 7, yield qw<pie good>, $_[0] => SUB }
+
+sub wlist (@) { return @_ }
+
+$res = wlist pie 1;
+is $res, 3, 'yield to list prototype to scalar';
+
+@res = wlist pie 2;
+is_deeply \@res, [ qw<pie good 2> ], 'yield to list prototype to list';
+
+sub wscalar ($$) { return @_ }
+
+$res = wscalar pie(6), pie(7);
+is $res, 2, 'yield to scalar prototype to scalar';
+
+@res = wscalar pie(8), pie(9);
+is_deeply \@res, [ 8, 9 ], 'yield to scalar prototype to list';
+
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 4 * 3;
+
+use lib 't/lib';
+use VPIT::TestHelpers;
+
+use Scope::Upper qw<yield HERE>;
+
+# Test timely destruction of values returned from yield()
+
+our $destroyed;
+sub guard { VPIT::TestHelpers::Guard->new(sub { ++$destroyed }) }
+
+{
+ my $desc = 'scalar context, above';
+ local $destroyed;
+ {
+ my $obj = guard();
+ my $res = do {
+ is $destroyed, undef, "$desc: not yet destroyed 1";
+ yield $obj => HERE;
+ fail 'not reached 1';
+ };
+ is $destroyed, undef, "$desc: not yet destroyed 2";
+ }
+ is $destroyed, 1, "$desc: destroyed 1";
+}
+
+{
+ my $desc = 'scalar context, below';
+ local $destroyed;
+ {
+ my $res = do {
+ my $obj = guard();
+ is $destroyed, undef, "$desc: not yet destroyed 1";
+ yield $obj => HERE;
+ fail 'not reached 1';
+ };
+ is $destroyed, undef, "$desc: not yet destroyed 2";
+ }
+ is $destroyed, 1, "$desc: destroyed 1";
+}
+
+{
+ my $desc = 'void context, above';
+ local $destroyed;
+ {
+ my $obj = guard();
+ {
+ is $destroyed, undef, "$desc: not yet destroyed 1";
+ yield $obj => HERE;
+ fail 'not reached 1';
+ }
+ is $destroyed, undef, "$desc: not yet destroyed 2";
+ }
+ is $destroyed, 1, "$desc: destroyed 1";
+}
+
+{
+ my $desc = 'void context, below';
+ local $destroyed;
+ {
+ {
+ is $destroyed, undef, "$desc: not yet destroyed 1";
+ my $obj = guard();
+ yield $obj => HERE;
+ fail 'not reached 2';
+ }
+ is $destroyed, 1, "$desc: destroyed 1";
+ }
+ is $destroyed, 1, "$desc: destroyed 2";
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use lib 't/lib';
+use Scope::Upper::TestThreads;
+
+use Test::Leaner;
+
+use Scope::Upper qw<yield UP>;
+
+our $z;
+
+sub up1 {
+ my $tid = threads->tid();
+ local $z = $tid;
+ my $p = "[$tid] up1";
+
+ usleep rand(1e6);
+
+ my @res = (
+ -1,
+ do {
+ my @dummy = (
+ 999,
+ map {
+ my $foo = yield $tid .. $tid + 2 => UP;
+ fail "$p: not reached";
+ } 666
+ );
+ fail "$p: not reached";
+ },
+ -2
+ );
+
+ is_deeply \@res, [ -1, $tid .. $tid + 2, -2 ], "$p: yielded correctly";
+}
+
+my @threads = map spawn(\&up1), 1 .. 30;
+
+$_->join for @threads;
+
+pass 'done';
+
+done_testing(scalar(@threads) + 1);
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use lib 't/lib';
+use Test::Leaner 'no_plan';
+
+use Scope::Upper qw<yield HERE SCOPE>;
+
+# @_[0 .. $#_] also ought to work, but it sometimes evaluates to nonsense in
+# scalar context on perl 5.8.5 and below.
+
+sub list { wantarray ? @_ : $_[$#_] }
+
+my @blocks = (
+ [
+ 'do {',
+ '}'
+ ],
+ [
+ '(list map {', # map in scalar context yields the number of elements
+ '} 1)'
+ ],
+ [
+ 'sub {
+ my $next = shift;',
+ '}->($next, @_)'
+ ],
+ [
+ 'eval {',
+ '}'
+ ],
+);
+
+my @contexts = (
+ [ '', '; ()', 'v' ],
+ [ 'scalar(', ')', 's' ],
+ [ 'list(', ')', 'l' ],
+);
+
+sub linearize { join ', ', map { defined($_) ? $_ : '(undef)' } @_ }
+
+our @stack;
+our @pre;
+
+# Don't put closures in empty pads on 5.6.
+
+my $dummy;
+my $capture_outer_pad = "$]" < 5.008 ? "++\$dummy;" : '';
+
+my @test_frames;
+
+for my $block (@blocks) {
+ for my $context (@contexts) {
+ my $source = <<"FRAME";
+ sub {
+ my \$next = shift; $capture_outer_pad
+ $block->[0]
+ unshift \@stack, HERE;
+ $context->[0]
+ (\@{shift \@pre}, \$next->[0]->(\@_))
+ $context->[1]
+ $block->[1]
+ }
+FRAME
+ my $code;
+ {
+ local $@;
+ $code = do {
+ no warnings 'void';
+ eval $source;
+ };
+ my $err = $@;
+ chomp $err;
+ die "$err. Source was :\n$source\n" if $@;
+ }
+ push @test_frames, [ $code, $source, $context->[2] ];
+ }
+}
+
+my @targets = (
+ [ sub {
+ my $depth = pop;
+ unshift @stack, HERE;
+ yield(@_ => $stack[$depth]);
+ }, 'target context from HERE' ],
+ [ sub {
+ my $depth = pop;
+ yield(@_ => SCOPE($depth == 0 ? 0 : (2 * ($depth - 1) + 1)));
+ }, 'target context from SCOPE' ],
+);
+
+my $seed = 0;
+
+for my $args ([ ], [ 'A' ], [ qw<B C> ]) {
+ my @args = @$args;
+ for my $frame0 (@test_frames) {
+ for my $frame1 (@test_frames) {
+ for my $frame2 (@test_frames) {
+ my $max_depth = 3;
+ $seed += 5; # Coprime with $max_depth
+ my @prepend;
+ for (1 .. $max_depth) {
+ ++$seed;
+ my $i = $seed + $_;
+ my $l = $seed % $max_depth - 1;
+ push @prepend, [ $i .. ($i + $l) ];
+ }
+ my $prepend_str = join ' ', map { '[' . join(' ', @$_) . ']' } @prepend;
+ for my $depth (0 .. $max_depth) {
+ my $exp = do {
+ my @cxts = map $_->[2], $frame0, $frame1, $frame2;
+ my @exp = @args;
+ for (my $i = $depth + 1; $i <= $max_depth; ++$i) {
+ my $c = $cxts[$max_depth - $i];
+ if ($c eq 'v') {
+ @exp = ();
+ } elsif ($c eq 's') {
+ @exp = @exp ? $exp[-1] : undef;
+ } else {
+ unshift @exp, @{$prepend[$max_depth - $i]};
+ }
+ }
+ linearize @exp;
+ };
+ for my $target (@targets) {
+ local @stack;
+ local @pre = @prepend;
+ my @res = $frame0->[0]->($frame1, $frame2, $target, @args, $depth);
+ my $got = linearize @res;
+ if ($got ne $exp) {
+ diag <<DIAG;
+=== This testcase failed ===
+$frame0->[1]
+$frame1->[1]
+$frame2->[1]
+$target->[1]
+==== vvvvv Errors vvvvvv ===
+DIAG
+ }
+ is $got, $exp, "yield to depth $depth with args [@args] and prepending $prepend_str";
+ }
+ }
+ }
+ }
+ }
+}
projects / perl / modules / Scope-Upper.git / commitdiff