8 plan tests => 1 + 23 * ($^P ? 4 : 5) + ($^P ? 1 : 3) + 7 + (32 + 7);
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.
16 my $warn_catcher = sub {
18 ++$got_warn if $_[0] =~ /^Cannot target a scope outside of the current stack at \Q$file\E line \d+\.$/;
25 is $top, 0, 'main : here' unless $^P;
26 is TOP, $top, 'main : top';
27 $old_sig_warn = $SIG{__WARN__};
28 local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
29 is UP, $top, 'main : up';
30 local $SIG{__WARN__} = $old_sig_warn;
31 is $got_warn, 1, 'main : up warns';
32 is SUB, undef, 'main : sub';
33 is EVAL, undef, 'main : eval';
37 is HERE, 1, "$desc : here" unless $^P;
38 is TOP, $top, "$desc : top";
39 is UP, $top, "$desc : up";
40 is SUB, undef, "$desc : sub";
41 is EVAL, undef, "$desc : eval";
45 my $desc = 'do { 1 }';
46 is HERE, 1, "$desc : here" unless $^P;
47 is TOP, $top, "$desc : top";
48 is UP, $top, "$desc : up";
49 is SUB, undef, "$desc : sub";
50 is EVAL, undef, "$desc : eval";
54 my $desc = 'eval { 1 }';
55 is HERE, 1, "$desc : here" unless $^P;
56 is TOP, $top, "$desc : top";
57 is UP, $top, "$desc : up";
58 is SUB, undef, "$desc : sub";
59 is EVAL, HERE, "$desc : eval";
64 my $desc = 'eval "1"';
65 is HERE, 1, "$desc : here" unless $^P;
66 is TOP, $top, "$desc : top";
67 is UP, $top, "$desc : up";
68 is SUB, undef, "$desc : sub";
69 is EVAL, HERE, "$desc : eval";
74 my $desc = 'sub { 1 }';
75 is HERE, 1, "$desc : here" unless $^P;
76 is TOP, $top, "$desc : top";
77 is UP, $top, "$desc : up";
78 is SUB, HERE, "$desc : sub";
79 is EVAL, undef, "$desc : eval";
86 my $desc = 'if () { 1 }';
87 is HERE, 1, "$desc : here" unless $^P;
88 is TOP, $top, "$desc : top";
89 is UP, $top, "$desc : up";
90 is SUB, undef, "$desc : sub";
91 is EVAL, undef, "$desc : eval";
95 my $desc = 'unless () { 1 }';
96 is HERE, 1, "$desc : here" unless $^P;
97 is TOP, $top, "$desc : top";
98 is UP, $top, "$desc : up";
99 is SUB, undef, "$desc : sub";
100 is EVAL, undef, "$desc : eval";
104 fail "false was true : $_" for 1 .. 5;
106 my $desc = 'if () { } else { 1 }';
107 is HERE, 1, "$desc : here" unless $^P;
108 is TOP, $top, "$desc : top";
109 is UP, $top, "$desc : up";
110 is SUB, undef, "$desc : sub";
111 is EVAL, undef, "$desc : eval";
115 my $desc = 'for (list) { 1 }';
116 is HERE, 1, "$desc : here" unless $^P;
117 is TOP, $top, "$desc : top";
118 is UP, $top, "$desc : up";
119 is SUB, undef, "$desc : sub";
120 is EVAL, undef, "$desc : eval";
124 my $desc = 'for (num range) { 1 }';
125 is HERE, 1, "$desc : here" unless $^P;
126 is TOP, $top, "$desc : top";
127 is UP, $top, "$desc : up";
128 is SUB, undef, "$desc : sub";
129 is EVAL, undef, "$desc : eval";
133 my $desc = 'for (pv range) { 1 }';
134 is HERE, 1, "$desc : here" unless $^P;
135 is TOP, $top, "$desc : top";
136 is UP, $top, "$desc : up";
137 is SUB, undef, "$desc : sub";
138 is EVAL, undef, "$desc : eval";
141 for (my $i = 0; $i < 1; ++$i) {
142 my $desc = 'for (;;) { 1 }';
143 is HERE, 1, "$desc : here" unless $^P;
144 is TOP, $top, "$desc : top";
145 is UP, $top, "$desc : up";
146 is SUB, undef, "$desc : sub";
147 is EVAL, undef, "$desc : eval";
153 my $desc = 'while () { 1 }';
154 is HERE, 1, "$desc : here" unless $^P;
155 is TOP, $top, "$desc : top";
156 is UP, $top, "$desc : up";
157 is SUB, undef, "$desc : sub";
158 is EVAL, undef, "$desc : eval";
162 while (my $thing = shift @list) {
163 my $desc = 'while (my $thing = ...) { 2 }';
164 is HERE, 1, "$desc : here" unless $^P;
165 is TOP, $top, "$desc : top";
166 is UP, $top, "$desc : up";
167 is SUB, undef, "$desc : sub";
168 is EVAL, undef, "$desc : eval";
172 my $desc = 'do { 1 } while (0)';
173 is HERE, 1, "$desc : here" unless $^P;
174 is TOP, $top, "$desc : top";
175 is UP, $top, "$desc : up";
176 is SUB, undef, "$desc : sub";
177 is EVAL, undef, "$desc : eval";
181 my $desc = 'map { 1 } 1';
182 is HERE, 1, "$desc : here" unless $^P;
183 is TOP, $top, "$desc : top";
184 is UP, $top, "$desc : up";
185 is SUB, undef, "$desc : sub";
186 is EVAL, undef, "$desc : eval";
190 my $desc = 'grep { 1 } 1';
191 is HERE, 1, "$desc : here" unless $^P;
192 is TOP, $top, "$desc : top";
193 is UP, $top, "$desc : up";
194 is SUB, undef, "$desc : sub";
195 is EVAL, undef, "$desc : eval";
201 is HERE, 1, "$desc : here" unless $^P;
202 is TOP, $top, "$desc : top";
203 is UP, $top, "$desc : up";
204 is SUB, undef, "$desc : sub";
205 is EVAL, undef, "$desc : eval";
210 is $var, $top, 'subst : fake block';
213 $var =~ s{.}{do { UP }}e;
214 is $var, 1, 'subst : do block optimized away' unless $^P;
217 $var =~ s{.}{do { my $x; UP }}e;
218 is $var, 1, 'subst : do block preserved' unless $^P;
221 skip 'Perl 5.10 required to test given/when' => 4 * ($^P ? 4 : 5)
226 if ("$]" >= 5.017_011) {
228 warnings->unimport('experimental::smartmatch');
231 use feature 'switch';
235 is HERE, $base + 1, "$desc : here" unless $^P;
236 is TOP, $top, "$desc : top";
237 is UP, $base, "$desc : up";
238 is SUB, undef, "$desc : sub";
239 is EVAL, $base, "$desc : eval";
244 eval <<'TEST_GIVEN_WHEN';
246 if ("$]" >= 5.017_011) {
248 warnings->unimport('experimental::smartmatch');
251 use feature 'switch';
252 my $desc = 'when in given';
257 is HERE, $base + 3, "$desc : here" unless $^P;
258 is TOP, $top, "$desc : top";
259 is UP, $given, "$desc : up";
260 is SUB, undef, "$desc : sub";
261 is EVAL, $base, "$desc : eval";
267 eval <<'TEST_GIVEN_DEFAULT';
269 if ("$]" >= 5.017_011) {
271 warnings->unimport('experimental::smartmatch');
274 use feature 'switch';
275 my $desc = 'default in given';
280 is HERE, $base + 3, "$desc : here" unless $^P;
281 is TOP, $top, "$desc : top";
282 is UP, $given, "$desc : up";
283 is SUB, undef, "$desc : sub";
284 is EVAL, $base, "$desc : eval";
290 eval <<'TEST_FOR_WHEN';
292 if ("$]" >= 5.017_011) {
294 warnings->unimport('experimental::smartmatch');
297 use feature 'switch';
298 my $desc = 'when in for';
303 is HERE, $base + 2, "$desc : here" unless $^P;
304 is TOP, $top, "$desc : top";
305 is UP, $loop, "$desc : up";
306 is SUB, undef, "$desc : sub";
307 is EVAL, $base, "$desc : eval";
315 skip 'Hardcoded values are wrong under the debugger' => 7 if $^P;
325 is HERE, $base + 6, 'mixed : here';
326 is TOP, $top, 'mixed : top';
327 is SUB, $base + 4, 'mixed : first sub';
328 is SUB(SUB), $base + 4, 'mixed : still first sub';
329 is EVAL, $base + 5, 'mixed : first eval';
330 is EVAL(EVAL), $base + 5, 'mixed : still first eval';
331 is EVAL(UP(EVAL)), $base + 2, 'mixed : second eval';
342 is SCOPE, $block, 'block : scope';
343 is SCOPE(0), $block, 'block : scope 0';
344 is SCOPE(1), $top, 'block : scope 1';
345 $old_sig_warn = $SIG{__WARN__};
346 local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
347 is SCOPE(2), $top, 'block : scope 2';
348 is $got_warn, 1, 'block : scope 2 warns';
350 is CALLER, $top, 'block : caller';
351 is $got_warn, 1, 'block : caller warns';
353 is CALLER(0), $top, 'block : caller 0';
354 is $got_warn, 1, 'block : caller 0 warns';
356 is CALLER(1), $top, 'block : caller 1';
357 is $got_warn, 1, 'block : caller 1 warns';
358 local $SIG{__WARN__} = $old_sig_warn;
361 is SCOPE, $sub, 'block sub : scope';
362 is SCOPE(0), $sub, 'block sub : scope 0';
363 is SCOPE(1), $block, 'block sub : scope 1';
364 is SCOPE(2), $top, 'block sub : scope 2';
365 is CALLER, $sub, 'block sub : caller';
366 is CALLER(0), $sub, 'block sub : caller 0';
367 $old_sig_warn = $SIG{__WARN__};
368 local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
369 is CALLER(1), $top, 'block sub : caller 1';
370 local $SIG{__WARN__} = $old_sig_warn;
371 is $got_warn, 1, 'block sub : caller 1 warns';
374 is SCOPE, $loop, 'block sub for : scope';
375 is SCOPE(0), $loop, 'block sub for : scope 0';
376 is SCOPE(1), $sub, 'block sub for : scope 1';
377 is SCOPE(2), $block, 'block sub for : scope 2';
378 is SCOPE(3), $top, 'block sub for : scope 3';
379 is CALLER, $sub, 'block sub for : caller';
380 is CALLER(0), $sub, 'block sub for : caller 0';
381 $old_sig_warn = $SIG{__WARN__};
382 local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
383 is CALLER(1), $top, 'block sub for : caller 1';
384 local $SIG{__WARN__} = $old_sig_warn;
385 is $got_warn, 1, 'block sub for : caller 1 warns';
388 is SCOPE, $eval, 'block sub for eval : scope';
389 is SCOPE(0), $eval, 'block sub for eval : scope 0';
390 is SCOPE(1), $loop, 'block sub for eval : scope 1';
391 is SCOPE(2), $sub, 'block sub for eval : scope 2';
392 is SCOPE(3), $block, 'block sub for eval : scope 3';
393 is SCOPE(4), $top, 'block sub for eval : scope 4';
394 is CALLER, $eval, 'block sub for eval : caller';
395 is CALLER(0), $eval, 'block sub for eval : caller 0';
396 is CALLER(1), $sub, 'block sub for eval : caller 1';
397 $old_sig_warn = $SIG{__WARN__};
398 local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
399 is CALLER(2), $top, 'block sub for eval : caller 2';
400 local $SIG{__WARN__} = $old_sig_warn;
401 is $got_warn, 1, 'block sub for eval : caller 2 warns';