8 plan tests => 23 * ($^P ? 4 : 5) + ($^P ? 1 : 3) + 7 + 15 * 2;
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.
17 is $top, 0, 'main : here' unless $^P;
18 is TOP, $top, 'main : top';
19 is UP, $top, 'main : up';
20 is SUB, undef, 'main : sub';
21 is EVAL, undef, 'main : eval';
25 is HERE, 1, "$desc : here" unless $^P;
26 is TOP, $top, "$desc : top";
27 is UP, $top, "$desc : up";
28 is SUB, undef, "$desc : sub";
29 is EVAL, undef, "$desc : eval";
33 my $desc = 'do { 1 }';
34 is HERE, 1, "$desc : here" unless $^P;
35 is TOP, $top, "$desc : top";
36 is UP, $top, "$desc : up";
37 is SUB, undef, "$desc : sub";
38 is EVAL, undef, "$desc : eval";
42 my $desc = 'eval { 1 }';
43 is HERE, 1, "$desc : here" unless $^P;
44 is TOP, $top, "$desc : top";
45 is UP, $top, "$desc : up";
46 is SUB, undef, "$desc : sub";
47 is EVAL, HERE, "$desc : eval";
52 my $desc = 'eval "1"';
53 is HERE, 1, "$desc : here" unless $^P;
54 is TOP, $top, "$desc : top";
55 is UP, $top, "$desc : up";
56 is SUB, undef, "$desc : sub";
57 is EVAL, HERE, "$desc : eval";
62 my $desc = 'sub { 1 }';
63 is HERE, 1, "$desc : here" unless $^P;
64 is TOP, $top, "$desc : top";
65 is UP, $top, "$desc : up";
66 is SUB, HERE, "$desc : sub";
67 is EVAL, undef, "$desc : eval";
74 my $desc = 'if () { 1 }';
75 is HERE, 1, "$desc : here" unless $^P;
76 is TOP, $top, "$desc : top";
77 is UP, $top, "$desc : up";
78 is SUB, undef, "$desc : sub";
79 is EVAL, undef, "$desc : eval";
83 my $desc = 'unless () { 1 }';
84 is HERE, 1, "$desc : here" unless $^P;
85 is TOP, $top, "$desc : top";
86 is UP, $top, "$desc : up";
87 is SUB, undef, "$desc : sub";
88 is EVAL, undef, "$desc : eval";
92 fail "false was true : $_" for 1 .. 5;
94 my $desc = 'if () { } else { 1 }';
95 is HERE, 1, "$desc : here" unless $^P;
96 is TOP, $top, "$desc : top";
97 is UP, $top, "$desc : up";
98 is SUB, undef, "$desc : sub";
99 is EVAL, undef, "$desc : eval";
103 my $desc = 'for (list) { 1 }';
104 is HERE, 1, "$desc : here" unless $^P;
105 is TOP, $top, "$desc : top";
106 is UP, $top, "$desc : up";
107 is SUB, undef, "$desc : sub";
108 is EVAL, undef, "$desc : eval";
112 my $desc = 'for (num range) { 1 }';
113 is HERE, 1, "$desc : here" unless $^P;
114 is TOP, $top, "$desc : top";
115 is UP, $top, "$desc : up";
116 is SUB, undef, "$desc : sub";
117 is EVAL, undef, "$desc : eval";
121 my $desc = 'for (pv range) { 1 }';
122 is HERE, 1, "$desc : here" unless $^P;
123 is TOP, $top, "$desc : top";
124 is UP, $top, "$desc : up";
125 is SUB, undef, "$desc : sub";
126 is EVAL, undef, "$desc : eval";
129 for (my $i = 0; $i < 1; ++$i) {
130 my $desc = 'for (;;) { 1 }';
131 is HERE, 1, "$desc : here" unless $^P;
132 is TOP, $top, "$desc : top";
133 is UP, $top, "$desc : up";
134 is SUB, undef, "$desc : sub";
135 is EVAL, undef, "$desc : eval";
141 my $desc = 'while () { 1 }';
142 is HERE, 1, "$desc : here" unless $^P;
143 is TOP, $top, "$desc : top";
144 is UP, $top, "$desc : up";
145 is SUB, undef, "$desc : sub";
146 is EVAL, undef, "$desc : eval";
150 while (my $thing = shift @list) {
151 my $desc = 'while (my $thing = ...) { 2 }';
152 is HERE, 1, "$desc : here" unless $^P;
153 is TOP, $top, "$desc : top";
154 is UP, $top, "$desc : up";
155 is SUB, undef, "$desc : sub";
156 is EVAL, undef, "$desc : eval";
160 my $desc = 'do { 1 } while (0)';
161 is HERE, 1, "$desc : here" unless $^P;
162 is TOP, $top, "$desc : top";
163 is UP, $top, "$desc : up";
164 is SUB, undef, "$desc : sub";
165 is EVAL, undef, "$desc : eval";
169 my $desc = 'map { 1 } 1';
170 is HERE, 1, "$desc : here" unless $^P;
171 is TOP, $top, "$desc : top";
172 is UP, $top, "$desc : up";
173 is SUB, undef, "$desc : sub";
174 is EVAL, undef, "$desc : eval";
178 my $desc = 'grep { 1 } 1';
179 is HERE, 1, "$desc : here" unless $^P;
180 is TOP, $top, "$desc : top";
181 is UP, $top, "$desc : up";
182 is SUB, undef, "$desc : sub";
183 is EVAL, undef, "$desc : eval";
189 is HERE, 1, "$desc : here" unless $^P;
190 is TOP, $top, "$desc : top";
191 is UP, $top, "$desc : up";
192 is SUB, undef, "$desc : sub";
193 is EVAL, undef, "$desc : eval";
198 is $var, $top, 'subst : fake block';
201 $var =~ s{.}{do { UP }}e;
202 is $var, 1, 'subst : do block optimized away' unless $^P;
205 $var =~ s{.}{do { my $x; UP }}e;
206 is $var, 1, 'subst : do block preserved' unless $^P;
209 skip 'Perl 5.10 required to test given/when' => 4 * ($^P ? 4 : 5)
214 if ("$]" >= 5.017_011) {
216 warnings->unimport('experimental::smartmatch');
219 use feature 'switch';
223 is HERE, $base + 1, "$desc : here" unless $^P;
224 is TOP, $top, "$desc : top";
225 is UP, $base, "$desc : up";
226 is SUB, undef, "$desc : sub";
227 is EVAL, $base, "$desc : eval";
232 eval <<'TEST_GIVEN_WHEN';
234 if ("$]" >= 5.017_011) {
236 warnings->unimport('experimental::smartmatch');
239 use feature 'switch';
240 my $desc = 'when in given';
245 is HERE, $base + 3, "$desc : here" unless $^P;
246 is TOP, $top, "$desc : top";
247 is UP, $given, "$desc : up";
248 is SUB, undef, "$desc : sub";
249 is EVAL, $base, "$desc : eval";
255 eval <<'TEST_GIVEN_DEFAULT';
257 if ("$]" >= 5.017_011) {
259 warnings->unimport('experimental::smartmatch');
262 use feature 'switch';
263 my $desc = 'default in given';
268 is HERE, $base + 3, "$desc : here" unless $^P;
269 is TOP, $top, "$desc : top";
270 is UP, $given, "$desc : up";
271 is SUB, undef, "$desc : sub";
272 is EVAL, $base, "$desc : eval";
278 eval <<'TEST_FOR_WHEN';
280 if ("$]" >= 5.017_011) {
282 warnings->unimport('experimental::smartmatch');
285 use feature 'switch';
286 my $desc = 'when in for';
291 is HERE, $base + 2, "$desc : here" unless $^P;
292 is TOP, $top, "$desc : top";
293 is UP, $loop, "$desc : up";
294 is SUB, undef, "$desc : sub";
295 is EVAL, $base, "$desc : eval";
303 skip 'Hardcoded values are wrong under the debugger' => 7 if $^P;
313 is HERE, $base + 6, 'mixed : here';
314 is TOP, $top, 'mixed : top';
315 is SUB, $base + 4, 'mixed : first sub';
316 is SUB(SUB), $base + 4, 'mixed : still first sub';
317 is EVAL, $base + 5, 'mixed : first eval';
318 is EVAL(EVAL), $base + 5, 'mixed : still first eval';
319 is EVAL(UP(EVAL)), $base + 2, 'mixed : second eval';
330 is SCOPE, $block, 'block : scope';
331 is SCOPE(0), $block, 'block : scope 0';
332 is SCOPE(1), $top, 'block : scope 1';
333 is CALLER, $top, 'block : caller';
334 is CALLER(0), $top, 'block : caller 0';
335 is CALLER(1), $top, 'block : caller 1';
338 is SCOPE, $sub, 'block sub : scope';
339 is SCOPE(0), $sub, 'block sub : scope 0';
340 is SCOPE(1), $block, 'block sub : scope 1';
341 is CALLER, $sub, 'block sub : caller';
342 is CALLER(0), $sub, 'block sub : caller 0';
343 is CALLER(1), $top, 'block sub : caller 1';
346 is SCOPE, $loop, 'block sub for : scope';
347 is SCOPE(0), $loop, 'block sub for : scope 0';
348 is SCOPE(1), $sub, 'block sub for : scope 1';
349 is SCOPE(2), $block, 'block sub for : scope 2';
350 is CALLER, $sub, 'block sub for : caller';
351 is CALLER(0), $sub, 'block sub for : caller 0';
352 is CALLER(1), $top, 'block sub for : caller 1';
353 is CALLER(2), $top, 'block sub for : caller 2';
356 is SCOPE, $eval, 'block sub for eval : scope';
357 is SCOPE(0), $eval, 'block sub for eval : scope 0';
358 is SCOPE(1), $loop, 'block sub for eval : scope 1';
359 is SCOPE(2), $sub, 'block sub for eval : scope 2';
360 is SCOPE(3), $block, 'block sub for eval : scope 3';
361 is CALLER, $eval, 'block sub for eval : caller';
362 is CALLER(0), $eval, 'block sub for eval : caller 0';
363 is CALLER(1), $sub, 'block sub for eval : caller 1';
364 is CALLER(2), $top, 'block sub for eval : caller 2';
365 is CALLER(3), $top, 'block sub for eval : caller 3';