8 plan tests => 23 * ($^P ? 4 : 5) + 40 + ($^P ? 1 : 3) + 7 + (32 + 7) + 1;
10 use Scope::Upper qw<:words>;
12 # Tests with hardcoded values are for internal use only and doesn't imply any
13 # kind of future compatibility on what the words should actually return.
15 my $stray_warnings = 0;
16 local $SIG{__WARN__} = sub {
22 my $warn_catcher = sub {
24 if ($_[0] =~ /^Cannot target a scope outside of the current stack at /) {
26 } elsif ($_[0] =~ /^No targetable (subroutine|eval) scope in the current stack at /) {
40 is $top, 0, 'main : here' unless $^P;
41 is TOP, $top, 'main : top';
42 $old_sig_warn = $SIG{__WARN__};
43 local ($SIG{__WARN__}, @warns) = $warn_catcher;
44 is UP, $top, 'main : up';
45 is "@warns", 'smash', 'main : up warns';
47 is SUB, undef, 'main : sub';
48 is "@warns", 'subroutine', 'main : sub warns';
50 is EVAL, undef, 'main : eval';
51 is "@warns", 'eval', 'main : eval warns';
52 local $SIG{__WARN__} = $old_sig_warn;
56 is HERE, 1, "$desc : here" unless $^P;
57 is TOP, $top, "$desc : top";
58 is UP, $top, "$desc : up";
59 $old_sig_warn = $SIG{__WARN__};
60 local ($SIG{__WARN__}, @warns) = $warn_catcher;
61 is SUB, undef, "$desc : sub";
62 is "@warns", 'subroutine', "$desc : sub warns";
64 is EVAL, undef, "$desc : eval";
65 is "@warns", 'eval', "$desc : eval warns";
66 local $SIG{__WARN__} = $old_sig_warn;
70 my $desc = 'do { 1 }';
71 is HERE, 1, "$desc : here" unless $^P;
72 is TOP, $top, "$desc : top";
73 is UP, $top, "$desc : up";
74 $old_sig_warn = $SIG{__WARN__};
75 local ($SIG{__WARN__}, @warns) = $warn_catcher;
76 is SUB, undef, "$desc : sub";
77 is "@warns", 'subroutine', "$desc : sub warns";
79 is EVAL, undef, "$desc : eval";
80 is "@warns", 'eval', "$desc : eval warns";
81 local $SIG{__WARN__} = $old_sig_warn;
85 my $desc = 'eval { 1 }';
86 is HERE, 1, "$desc : here" unless $^P;
87 is TOP, $top, "$desc : top";
88 is UP, $top, "$desc : up";
89 $old_sig_warn = $SIG{__WARN__};
90 local ($SIG{__WARN__}, @warns) = $warn_catcher;
91 is SUB, undef, "$desc : sub";
92 is "@warns", 'subroutine', "$desc : sub warns";
93 local $SIG{__WARN__} = $old_sig_warn;
94 is EVAL, HERE, "$desc : eval";
99 my $desc = 'eval "1"';
100 is HERE, 1, "$desc : here" unless $^P;
101 is TOP, $top, "$desc : top";
102 is UP, $top, "$desc : up";
103 $old_sig_warn = $SIG{__WARN__};
104 local ($SIG{__WARN__}, @warns) = $warn_catcher;
105 is SUB, undef, "$desc : sub";
106 is "@warns", 'subroutine', "$desc : sub warns";
107 local $SIG{__WARN__} = $old_sig_warn;
108 is EVAL, HERE, "$desc : eval";
113 my $desc = 'sub { 1 }';
114 is HERE, 1, "$desc : here" unless $^P;
115 is TOP, $top, "$desc : top";
116 is UP, $top, "$desc : up";
117 is SUB, HERE, "$desc : sub";
118 $old_sig_warn = $SIG{__WARN__};
119 local ($SIG{__WARN__}, @warns) = $warn_catcher;
120 is EVAL, undef, "$desc : eval";
121 is "@warns", 'eval', "$desc : eval warns";
122 local $SIG{__WARN__} = $old_sig_warn;
129 my $desc = 'if () { 1 }';
130 is HERE, 1, "$desc : here" unless $^P;
131 is TOP, $top, "$desc : top";
132 is UP, $top, "$desc : up";
133 $old_sig_warn = $SIG{__WARN__};
134 local ($SIG{__WARN__}, @warns) = $warn_catcher;
135 is SUB, undef, "$desc : sub";
136 is "@warns", 'subroutine', "$desc : sub warns";
138 is EVAL, undef, "$desc : eval";
139 is "@warns", 'eval', "$desc : eval warns";
140 local $SIG{__WARN__} = $old_sig_warn;
144 my $desc = 'unless () { 1 }';
145 is HERE, 1, "$desc : here" unless $^P;
146 is TOP, $top, "$desc : top";
147 is UP, $top, "$desc : up";
148 $old_sig_warn = $SIG{__WARN__};
149 local ($SIG{__WARN__}, @warns) = $warn_catcher;
150 is SUB, undef, "$desc : sub";
151 is "@warns", 'subroutine', "$desc : sub warns";
153 is EVAL, undef, "$desc : eval";
154 is "@warns", 'eval', "$desc : eval warns";
155 local $SIG{__WARN__} = $old_sig_warn;
159 fail "false was true : $_" for 1 .. 5;
161 my $desc = 'if () { } else { 1 }';
162 is HERE, 1, "$desc : here" unless $^P;
163 is TOP, $top, "$desc : top";
164 is UP, $top, "$desc : up";
165 $old_sig_warn = $SIG{__WARN__};
166 local ($SIG{__WARN__}, @warns) = $warn_catcher;
167 is SUB, undef, "$desc : sub";
168 is "@warns", 'subroutine', "$desc : sub warns";
170 is EVAL, undef, "$desc : eval";
171 is "@warns", 'eval', "$desc : eval warns";
172 local $SIG{__WARN__} = $old_sig_warn;
176 my $desc = 'for (list) { 1 }';
177 is HERE, 1, "$desc : here" unless $^P;
178 is TOP, $top, "$desc : top";
179 is UP, $top, "$desc : up";
180 $old_sig_warn = $SIG{__WARN__};
181 local ($SIG{__WARN__}, @warns) = $warn_catcher;
182 is SUB, undef, "$desc : sub";
183 is "@warns", 'subroutine', "$desc : sub warns";
185 is EVAL, undef, "$desc : eval";
186 is "@warns", 'eval', "$desc : eval warns";
187 local $SIG{__WARN__} = $old_sig_warn;
191 my $desc = 'for (num range) { 1 }';
192 is HERE, 1, "$desc : here" unless $^P;
193 is TOP, $top, "$desc : top";
194 is UP, $top, "$desc : up";
195 $old_sig_warn = $SIG{__WARN__};
196 local ($SIG{__WARN__}, @warns) = $warn_catcher;
197 is SUB, undef, "$desc : sub";
198 is "@warns", 'subroutine', "$desc : sub warns";
200 is EVAL, undef, "$desc : eval";
201 is "@warns", 'eval', "$desc : eval warns";
202 local $SIG{__WARN__} = $old_sig_warn;
206 my $desc = 'for (pv range) { 1 }';
207 is HERE, 1, "$desc : here" unless $^P;
208 is TOP, $top, "$desc : top";
209 is UP, $top, "$desc : up";
210 $old_sig_warn = $SIG{__WARN__};
211 local ($SIG{__WARN__}, @warns) = $warn_catcher;
212 is SUB, undef, "$desc : sub";
213 is "@warns", 'subroutine', "$desc : sub warns";
215 is EVAL, undef, "$desc : eval";
216 is "@warns", 'eval', "$desc : eval warns";
217 local $SIG{__WARN__} = $old_sig_warn;
220 for (my $i = 0; $i < 1; ++$i) {
221 my $desc = 'for (;;) { 1 }';
222 is HERE, 1, "$desc : here" unless $^P;
223 is TOP, $top, "$desc : top";
224 is UP, $top, "$desc : up";
225 $old_sig_warn = $SIG{__WARN__};
226 local ($SIG{__WARN__}, @warns) = $warn_catcher;
227 is SUB, undef, "$desc : sub";
228 is "@warns", 'subroutine', "$desc : sub warns";
230 is EVAL, undef, "$desc : eval";
231 is "@warns", 'eval', "$desc : eval warns";
232 local $SIG{__WARN__} = $old_sig_warn;
238 my $desc = 'while () { 1 }';
239 is HERE, 1, "$desc : here" unless $^P;
240 is TOP, $top, "$desc : top";
241 is UP, $top, "$desc : up";
242 $old_sig_warn = $SIG{__WARN__};
243 local ($SIG{__WARN__}, @warns) = $warn_catcher;
244 is SUB, undef, "$desc : sub";
245 is "@warns", 'subroutine', "$desc : sub warns";
247 is EVAL, undef, "$desc : eval";
248 is "@warns", 'eval', "$desc : eval warns";
249 local $SIG{__WARN__} = $old_sig_warn;
253 while (my $thing = shift @list) {
254 my $desc = 'while (my $thing = ...) { 2 }';
255 is HERE, 1, "$desc : here" unless $^P;
256 is TOP, $top, "$desc : top";
257 is UP, $top, "$desc : up";
258 $old_sig_warn = $SIG{__WARN__};
259 local ($SIG{__WARN__}, @warns) = $warn_catcher;
260 is SUB, undef, "$desc : sub";
261 is "@warns", 'subroutine', "$desc : sub warns";
263 is EVAL, undef, "$desc : eval";
264 is "@warns", 'eval', "$desc : eval warns";
265 local $SIG{__WARN__} = $old_sig_warn;
269 my $desc = 'do { 1 } while (0)';
270 is HERE, 1, "$desc : here" unless $^P;
271 is TOP, $top, "$desc : top";
272 is UP, $top, "$desc : up";
273 $old_sig_warn = $SIG{__WARN__};
274 local ($SIG{__WARN__}, @warns) = $warn_catcher;
275 is SUB, undef, "$desc : sub";
276 is "@warns", 'subroutine', "$desc : sub warns";
278 is EVAL, undef, "$desc : eval";
279 is "@warns", 'eval', "$desc : eval warns";
280 local $SIG{__WARN__} = $old_sig_warn;
284 my $desc = 'map { 1 } 1';
285 is HERE, 1, "$desc : here" unless $^P;
286 is TOP, $top, "$desc : top";
287 is UP, $top, "$desc : up";
288 $old_sig_warn = $SIG{__WARN__};
289 local ($SIG{__WARN__}, @warns) = $warn_catcher;
290 is SUB, undef, "$desc : sub";
291 is "@warns", 'subroutine', "$desc : sub warns";
293 is EVAL, undef, "$desc : eval";
294 is "@warns", 'eval', "$desc : eval warns";
295 local $SIG{__WARN__} = $old_sig_warn;
299 my $desc = 'grep { 1 } 1';
300 is HERE, 1, "$desc : here" unless $^P;
301 is TOP, $top, "$desc : top";
302 is UP, $top, "$desc : up";
303 $old_sig_warn = $SIG{__WARN__};
304 local ($SIG{__WARN__}, @warns) = $warn_catcher;
305 is SUB, undef, "$desc : sub";
306 is "@warns", 'subroutine', "$desc : sub warns";
308 is EVAL, undef, "$desc : eval";
309 is "@warns", 'eval', "$desc : eval warns";
310 local $SIG{__WARN__} = $old_sig_warn;
316 is HERE, 1, "$desc : here" unless $^P;
317 is TOP, $top, "$desc : top";
318 is UP, $top, "$desc : up";
319 $old_sig_warn = $SIG{__WARN__};
320 local ($SIG{__WARN__}, @warns) = $warn_catcher;
321 is SUB, undef, "$desc : sub";
322 is "@warns", 'subroutine', "$desc : sub warns";
324 is EVAL, undef, "$desc : eval";
325 is "@warns", 'eval', "$desc : eval warns";
326 local $SIG{__WARN__} = $old_sig_warn;
331 is $var, $top, 'subst : fake block';
334 $var =~ s{.}{do { UP }}e;
335 is $var, 1, 'subst : do block optimized away' unless $^P;
338 $var =~ s{.}{do { my $x; UP }}e;
339 is $var, 1, 'subst : do block preserved' unless $^P;
342 skip 'Perl 5.10 required to test given/when' => 4 * ($^P ? 4 : 5) + 4
347 if ("$]" >= 5.017_011) {
349 warnings->unimport('experimental::smartmatch');
352 use feature 'switch';
356 is HERE, $base + 1, "$desc : here" unless $^P;
357 is TOP, $top, "$desc : top";
358 is UP, $base, "$desc : up";
359 $old_sig_warn = $SIG{__WARN__};
360 local ($SIG{__WARN__}, @warns) = $warn_catcher;
361 is SUB, undef, "$desc : sub";
362 is "@warns", 'subroutine', "$desc : sub warns";
363 local $SIG{__WARN__} = $old_sig_warn;
364 is EVAL, $base, "$desc : eval";
369 eval <<'TEST_GIVEN_WHEN';
371 if ("$]" >= 5.017_011) {
373 warnings->unimport('experimental::smartmatch');
376 use feature 'switch';
377 my $desc = 'when in given';
382 is HERE, $base + 3, "$desc : here" unless $^P;
383 is TOP, $top, "$desc : top";
384 is UP, $given, "$desc : up";
385 $old_sig_warn = $SIG{__WARN__};
386 local ($SIG{__WARN__}, @warns) = $warn_catcher;
387 is SUB, undef, "$desc : sub";
388 is "@warns", 'subroutine', "$desc : sub warns";
389 local $SIG{__WARN__} = $old_sig_warn;
390 is EVAL, $base, "$desc : eval";
396 eval <<'TEST_GIVEN_DEFAULT';
398 if ("$]" >= 5.017_011) {
400 warnings->unimport('experimental::smartmatch');
403 use feature 'switch';
404 my $desc = 'default in given';
409 is HERE, $base + 3, "$desc : here" unless $^P;
410 is TOP, $top, "$desc : top";
411 is UP, $given, "$desc : up";
412 $old_sig_warn = $SIG{__WARN__};
413 local ($SIG{__WARN__}, @warns) = $warn_catcher;
414 is SUB, undef, "$desc : sub";
415 is "@warns", 'subroutine', "$desc : sub warns";
416 local $SIG{__WARN__} = $old_sig_warn;
417 is EVAL, $base, "$desc : eval";
423 eval <<'TEST_FOR_WHEN';
425 if ("$]" >= 5.017_011) {
427 warnings->unimport('experimental::smartmatch');
430 use feature 'switch';
431 my $desc = 'when in for';
436 is HERE, $base + 2, "$desc : here" unless $^P;
437 is TOP, $top, "$desc : top";
438 is UP, $loop, "$desc : up";
439 $old_sig_warn = $SIG{__WARN__};
440 local ($SIG{__WARN__}, @warns) = $warn_catcher;
441 is SUB, undef, "$desc : sub";
442 is "@warns", 'subroutine', "$desc : sub warns";
443 local $SIG{__WARN__} = $old_sig_warn;
444 is EVAL, $base, "$desc : eval";
452 skip 'Hardcoded values are wrong under the debugger' => 7 if $^P;
462 is HERE, $base + 6, 'mixed : here';
463 is TOP, $top, 'mixed : top';
464 is SUB, $base + 4, 'mixed : first sub';
465 is SUB(SUB), $base + 4, 'mixed : still first sub';
466 is EVAL, $base + 5, 'mixed : first eval';
467 is EVAL(EVAL), $base + 5, 'mixed : still first eval';
468 is EVAL(UP(EVAL)), $base + 2, 'mixed : second eval';
479 is SCOPE, $block, 'block : scope';
480 is SCOPE(0), $block, 'block : scope 0';
481 is SCOPE(1), $top, 'block : scope 1';
482 $old_sig_warn = $SIG{__WARN__};
483 local ($SIG{__WARN__}, @warns) = $warn_catcher;
484 is SCOPE(2), $top, 'block : scope 2';
485 is "@warns", 'smash', 'block : scope 2 warns';
487 is CALLER, $top, 'block : caller';
488 is "@warns", 'smash', 'block : caller warns';
490 is CALLER(0), $top, 'block : caller 0';
491 is "@warns", 'smash', 'block : caller 0 warns';
493 is CALLER(1), $top, 'block : caller 1';
494 is "@warns", 'smash', 'block : caller 1 warns';
495 local $SIG{__WARN__} = $old_sig_warn;
498 is SCOPE, $sub, 'block sub : scope';
499 is SCOPE(0), $sub, 'block sub : scope 0';
500 is SCOPE(1), $block, 'block sub : scope 1';
501 is SCOPE(2), $top, 'block sub : scope 2';
502 is CALLER, $sub, 'block sub : caller';
503 is CALLER(0), $sub, 'block sub : caller 0';
504 $old_sig_warn = $SIG{__WARN__};
505 local ($SIG{__WARN__}, @warns) = $warn_catcher;
506 is CALLER(1), $top, 'block sub : caller 1';
507 is "@warns", 'smash', 'block sub : caller 1 warns';
508 local $SIG{__WARN__} = $old_sig_warn;
511 is SCOPE, $loop, 'block sub for : scope';
512 is SCOPE(0), $loop, 'block sub for : scope 0';
513 is SCOPE(1), $sub, 'block sub for : scope 1';
514 is SCOPE(2), $block, 'block sub for : scope 2';
515 is SCOPE(3), $top, 'block sub for : scope 3';
516 is CALLER, $sub, 'block sub for : caller';
517 is CALLER(0), $sub, 'block sub for : caller 0';
518 $old_sig_warn = $SIG{__WARN__};
519 local ($SIG{__WARN__}, @warns) = $warn_catcher;
520 is CALLER(1), $top, 'block sub for : caller 1';
521 is "@warns", 'smash', 'block sub for : caller 1 warns';
522 local $SIG{__WARN__} = $old_sig_warn;
525 is SCOPE, $eval, 'block sub for eval : scope';
526 is SCOPE(0), $eval, 'block sub for eval : scope 0';
527 is SCOPE(1), $loop, 'block sub for eval : scope 1';
528 is SCOPE(2), $sub, 'block sub for eval : scope 2';
529 is SCOPE(3), $block, 'block sub for eval : scope 3';
530 is SCOPE(4), $top, 'block sub for eval : scope 4';
531 is CALLER, $eval, 'block sub for eval : caller';
532 is CALLER(0), $eval, 'block sub for eval : caller 0';
533 is CALLER(1), $sub, 'block sub for eval : caller 1';
534 $old_sig_warn = $SIG{__WARN__};
535 local ($SIG{__WARN__}, @warns) = $warn_catcher;
536 is CALLER(2), $top, 'block sub for eval : caller 2';
537 is "@warns", 'smash', 'block sub for eval : caller 2 warns';
538 local $SIG{__WARN__} = $old_sig_warn;
544 is $stray_warnings, 0, 'no stray warnings';