6 use Test::More tests => 38 + 4 * 7;
8 use Scope::Upper qw/reap UP HERE/;
21 is $x, 2, 'goto 1 [not yet - x]';
22 is $y, undef, 'goto 1 [not yet - y]';
30 is $x, 1, 'goto 1 [ok - x]';
31 is $y, 1, 'goto 1 [ok - y]';
42 reap \&check => UP UP;
44 is $x, 3, 'goto 2 [not yet - x]';
45 is $y, undef, 'goto 2 [not yet - y]';
54 is $x, 1, 'goto 2 [ok - x]';
55 is $y, 1, 'goto 2 [ok - y]';
67 reap \&check => UP UP UP;
68 is $x, 3, 'die - reap outside eval [not yet 1 - x]';
69 is $y, undef, 'die - reap outside eval [not yet 1 - y]';
71 is $x, 2, 'die - reap outside eval [not yet 2 - x]';
72 is $y, undef, 'die - reap outside eval [not yet 2 - y]';
76 is $x, 1, 'die - reap outside eval [not yet 3 - x]';
77 is $y, undef, 'die - reap outside eval [not yet 3 - y]';
78 } # should trigger here
79 is $x, 1, 'die - reap outside eval [ok - x]';
80 is $y, 1, 'die - reap outside eval [ok - y]';
91 reap \&check => UP UP;
92 is $x, 3, 'die - reap at eval [not yet 1 - x]';
93 is $y, undef, 'die - reap at eval [not yet 1 - y]';
95 is $x, 2, 'die - reap at eval [not yet 2 - x]';
96 is $y, undef, 'die - reap at eval [not yet 2 - y]';
99 }; # should trigger here
100 is $x, 1, 'die - reap at eval [ok - x]';
101 is $y, 1, 'die - reap at eval [ok - y]';
113 is $x, 3, 'die - reap inside eval [not yet 1 - x]';
114 is $y, undef, 'die - reap inside eval [not yet 1 - y]';
116 is $x, 2, 'die - reap inside eval [not yet 2 - x]';
117 is $y, undef, 'die - reap inside eval [not yet 2 - y]';
119 } # should trigger here
121 is $x, 1, 'die - reap inside eval [ok - x]';
122 is $y, 1, 'die - reap inside eval [ok - y]';
132 reap { ++$y; die "reaped\n" } => HERE;
133 is $x, 3, 'die in reap at eval [not yet - x]';
134 is $y, undef, 'die in reap at eval [not yet - y]';
135 }; # should trigger here, but the die isn't catched by this eval
138 is $@, "reaped\n", 'die in reap at eval [ok - $@]';
139 is $x, 1, 'die in reap at eval [ok - x]';
140 is $y, 1, 'die in reap at eval [ok - y]';
150 reap { ++$y; die "reaped\n" } => HERE;
151 is $x, 3, 'die in reap inside eval [not yet - x]';
152 is $y, undef, 'die in reap inside eval [not yet - y]';
153 } # should trigger here
156 is $@, "reaped\n", 'die in reap inside eval [ok - $@]';
157 is $x, 1, 'die in reap inside eval [ok - x]';
158 is $y, 1, 'die in reap inside eval [ok - y]';
162 my ($cb, $desc) = @_;
167 is $x, 3, "$desc [not yet 1 - x]";
168 is $y, undef, "$desc [not yet 1 - y]";
170 is $x, 2, "$desc [not yet 2 - x]";
171 is $y, undef, "$desc [not yet 2 - y]";
175 for ([ sub { ++$y; 15, 16, 17, 18 }, 'implicit ' ],
176 [ sub { ++$y; return 15, 16, 17, 18 }, '' ]) {
177 my ($cb, $imp) = @$_;
178 $imp = "RT #44204 - ${imp}return from reap";
182 $desc = "$imp in list context";
184 my @l = hijacked($cb, $desc);
185 is $x, 1, "$desc [ok - x]";
186 is $y, 1, "$desc [ok - y]";
187 is_deeply \@l, [ 11, 12 ], "$desc [ok - l]";
191 $desc = "$imp in list context";
193 my $s = hijacked($cb, $desc);
194 is $x, 1, "$desc [ok - x]";
195 is $y, 1, "$desc [ok - y]";
196 is $s, 12, "$desc [ok - s]";