6 use Test::More tests => 41 + 30 + 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]';
129 reap { $reaped = 1 };
130 is $reaped, 0, 'died of natural death - not reaped yet';
134 is $reaped, 1, 'died of natural death - reaped';
135 like $err, qr/division by zero/, 'died of natural death - divided by zero';
140 skip 'Perl 5.10 required to test given/when' => 30 if "$]" < 5.010;
142 eval <<' GIVEN_TEST_1';
144 if ("$]" >= 5.017_011) {
146 warnings->unimport('experimental::smartmatch');
149 use feature 'switch';
158 is $x, 3, 'given/when - reap at given [not yet - x]';
159 is $y, undef, 'given/when - reap at given [not yet - y]';
163 is $x, 1, 'given/when - reap at given [ok - x]';
164 is $y, 1, 'given/when - reap at given [ok - y]';
169 eval <<' GIVEN_TEST_2';
171 if ("$]" >= 5.017_011) {
173 warnings->unimport('experimental::smartmatch');
176 use feature 'switch';
185 is $x, 3, 'given/when/continue - reap at given [not yet 1 - x]';
186 is $y, undef, 'given/when/continue - reap at given [not yet 1 - y]';
189 is $x, 2, 'given/when/continue - reap at given [not yet 2 - x]';
190 is $y, undef, 'given/when/continue - reap at given [not yet 2 - y]';
192 is $x, 1, 'given/when/continue - reap at given [ok - x]';
193 is $y, 1, 'given/when/continue - reap at given [ok - y]';
198 eval <<' GIVEN_TEST_3';
200 if ("$]" >= 5.017_011) {
202 warnings->unimport('experimental::smartmatch');
205 use feature 'switch';
214 is $x, 3, 'given/default - reap at given [not yet - x]';
215 is $y, undef, 'given/default - reap at given [not yet - y]';
219 is $x, 1, 'given/default - reap at given [ok - x]';
220 is $y, 1, 'given/default - reap at given [ok - y]';
225 eval <<' GIVEN_TEST_4';
227 if ("$]" >= 5.017_011) {
229 warnings->unimport('experimental::smartmatch');
232 use feature 'switch';
241 is $x, 3, 'given/default/continue - reap at given [not yet 1 - x]';
242 is $y, undef, 'given/default/continue - reap at given [not yet 1 - y]';
245 is $x, 2, 'given/default/continue - reap at given [not yet 2 - x]';
246 is $y, undef, 'given/default/continue - reap at given [not yet 2 - y]';
248 is $x, 1, 'given/default/continue - reap at given [ok - x]';
249 is $y, 1, 'given/default/continue - reap at given [ok - y]';
254 eval <<' GIVEN_TEST_5';
256 if ("$]" >= 5.017_011) {
258 warnings->unimport('experimental::smartmatch');
261 use feature 'switch';
273 reap \&check => UP UP;
274 is $x, 5, 'given/default/given/when - reap at default [not yet 1 - x]';
275 is $y, undef, 'given/default/given/when - reap at default [not yet 1 - y]';
278 is $x, 4, 'given/default/given/when - reap at default [not yet 2 - x]';
279 is $y, undef, 'given/default/given/when - reap at default [not yet 2 - y]';
281 is $x, 3, 'given/default/given/when - reap at default [not yet 3 - x]';
282 is $y, undef, 'given/default/given/when - reap at default [not yet 3 - y]';
285 is $x, 2, 'given/default/given/when - reap at default [ok 1 - x]';
286 is $y, 1, 'given/default/given/when - reap at default [ok 1 - y]';
288 is $x, 1, 'given/default/given/when - reap at default [ok 2 - x]';
289 is $y, 1, 'given/default/given/when - reap at default [ok 2 - y]';
302 reap { ++$y; die "reaped\n" } => HERE;
303 is $x, 3, 'die in reap at eval [not yet - x]';
304 is $y, undef, 'die in reap at eval [not yet - y]';
305 }; # should trigger here, but the die isn't catched by this eval
308 is $@, "reaped\n", 'die in reap at eval [ok - $@]';
309 is $x, 1, 'die in reap at eval [ok - x]';
310 is $y, 1, 'die in reap at eval [ok - y]';
320 reap { ++$y; die "reaped\n" } => HERE;
321 is $x, 3, 'die in reap inside eval [not yet - x]';
322 is $y, undef, 'die in reap inside eval [not yet - y]';
323 } # should trigger here
326 is $@, "reaped\n", 'die in reap inside eval [ok - $@]';
327 is $x, 1, 'die in reap inside eval [ok - x]';
328 is $y, 1, 'die in reap inside eval [ok - y]';
332 my ($cb, $desc) = @_;
337 is $x, 3, "$desc [not yet 1 - x]";
338 is $y, undef, "$desc [not yet 1 - y]";
340 is $x, 2, "$desc [not yet 2 - x]";
341 is $y, undef, "$desc [not yet 2 - y]";
345 for ([ sub { ++$y; 15, 16, 17, 18 }, 'implicit ' ],
346 [ sub { ++$y; return 15, 16, 17, 18 }, '' ]) {
347 my ($cb, $imp) = @$_;
348 $imp = "RT #44204 - ${imp}return from reap";
352 $desc = "$imp in list context";
354 my @l = hijacked($cb, $desc);
355 is $x, 1, "$desc [ok - x]";
356 is $y, 1, "$desc [ok - y]";
357 is_deeply \@l, [ 11, 12 ], "$desc [ok - l]";
361 $desc = "$imp in list context";
363 my $s = hijacked($cb, $desc);
364 is $x, 1, "$desc [ok - x]";
365 is $y, 1, "$desc [ok - y]";
366 is $s, 12, "$desc [ok - s]";