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)
213 use feature 'switch';
217 is HERE, $base + 1, "$desc : here" unless $^P;
218 is TOP, $top, "$desc : top";
219 is UP, $base, "$desc : up";
220 is SUB, undef, "$desc : sub";
221 is EVAL, $base, "$desc : eval";
226 eval <<'TEST_GIVEN_WHEN';
227 use feature 'switch';
228 my $desc = 'when in given';
233 is HERE, $base + 3, "$desc : here" unless $^P;
234 is TOP, $top, "$desc : top";
235 is UP, $given, "$desc : up";
236 is SUB, undef, "$desc : sub";
237 is EVAL, $base, "$desc : eval";
243 eval <<'TEST_GIVEN_DEFAULT';
244 use feature 'switch';
245 my $desc = 'default in given';
250 is HERE, $base + 3, "$desc : here" unless $^P;
251 is TOP, $top, "$desc : top";
252 is UP, $given, "$desc : up";
253 is SUB, undef, "$desc : sub";
254 is EVAL, $base, "$desc : eval";
260 eval <<'TEST_FOR_WHEN';
261 use feature 'switch';
262 my $desc = 'when in for';
267 is HERE, $base + 2, "$desc : here" unless $^P;
268 is TOP, $top, "$desc : top";
269 is UP, $loop, "$desc : up";
270 is SUB, undef, "$desc : sub";
271 is EVAL, $base, "$desc : eval";
279 skip 'Hardcoded values are wrong under the debugger' => 7 if $^P;
289 is HERE, $base + 6, 'mixed : here';
290 is TOP, $top, 'mixed : top';
291 is SUB, $base + 4, 'mixed : first sub';
292 is SUB(SUB), $base + 4, 'mixed : still first sub';
293 is EVAL, $base + 5, 'mixed : first eval';
294 is EVAL(EVAL), $base + 5, 'mixed : still first eval';
295 is EVAL(UP(EVAL)), $base + 2, 'mixed : second eval';
306 is SCOPE, $block, 'block : scope';
307 is SCOPE(0), $block, 'block : scope 0';
308 is SCOPE(1), $top, 'block : scope 1';
309 is CALLER, $top, 'block : caller';
310 is CALLER(0), $top, 'block : caller 0';
311 is CALLER(1), $top, 'block : caller 1';
314 is SCOPE, $sub, 'block sub : scope';
315 is SCOPE(0), $sub, 'block sub : scope 0';
316 is SCOPE(1), $block, 'block sub : scope 1';
317 is CALLER, $sub, 'block sub : caller';
318 is CALLER(0), $sub, 'block sub : caller 0';
319 is CALLER(1), $top, 'block sub : caller 1';
322 is SCOPE, $loop, 'block sub for : scope';
323 is SCOPE(0), $loop, 'block sub for : scope 0';
324 is SCOPE(1), $sub, 'block sub for : scope 1';
325 is SCOPE(2), $block, 'block sub for : scope 2';
326 is CALLER, $sub, 'block sub for : caller';
327 is CALLER(0), $sub, 'block sub for : caller 0';
328 is CALLER(1), $top, 'block sub for : caller 1';
329 is CALLER(2), $top, 'block sub for : caller 2';
332 is SCOPE, $eval, 'block sub for eval : scope';
333 is SCOPE(0), $eval, 'block sub for eval : scope 0';
334 is SCOPE(1), $loop, 'block sub for eval : scope 1';
335 is SCOPE(2), $sub, 'block sub for eval : scope 2';
336 is SCOPE(3), $block, 'block sub for eval : scope 3';
337 is CALLER, $eval, 'block sub for eval : caller';
338 is CALLER(0), $eval, 'block sub for eval : caller 0';
339 is CALLER(1), $sub, 'block sub for eval : caller 1';
340 is CALLER(2), $top, 'block sub for eval : caller 2';
341 is CALLER(3), $top, 'block sub for eval : caller 3';