Commit | Line | Data |
---|---|---|
83c7d349 NC |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | require "./test.pl"; | |
6 | set_up_inc('../lib'); | |
7 | } | |
8 | ||
9 | use strict; | |
10 | use warnings; | |
ebb7bd1b | 11 | use utf8; |
83c7d349 NC |
12 | |
13 | my @have; | |
14 | ||
8f563184 NC |
15 | { |
16 | my @warnings; | |
17 | BEGIN { $SIG{__WARN__} = sub { push @warnings, shift; }; } | |
18 | ||
19 | # This should not warn | |
20 | for my $q ('A', 'B', 'C', 'D') { | |
21 | push @have, "$q"; | |
22 | } | |
23 | is ("@have", 'A B C D', 'no list'); | |
24 | ||
25 | @have = (); | |
26 | # This should warn | |
27 | my $warn0 = __LINE__ + 1; | |
28 | for my ($q) ('A', 'B', 'C', 'D') { | |
29 | push @have, "$q"; | |
30 | } | |
31 | is ("@have", 'A B C D', 'list of 1'); | |
32 | ||
33 | @have = (); | |
34 | ||
35 | # Simplest case is an explicit list: | |
36 | my $warn1 = __LINE__ + 1; | |
37 | for my ($q, $r) ('A', 'B', 'C', 'D') { | |
38 | push @have, "$q;$r"; | |
39 | } | |
40 | is ("@have", 'A;B C;D', 'list of 2'); | |
41 | ||
42 | is(scalar @warnings, 2, "2 warnings"); | |
43 | is($warnings[0], "for my (...) is experimental at $0 line $warn0.\n", | |
44 | 'for my ($q) warned'); | |
45 | is($warnings[1], "for my (...) is experimental at $0 line $warn1.\n", | |
46 | 'for my ($q, $r) warned'); | |
47 | BEGIN { undef $SIG{__WARN__}; } | |
48 | } | |
49 | ||
50 | no warnings 'experimental::for_list'; | |
51 | ||
52 | @have = (); | |
53 | ||
83c7d349 NC |
54 | # Simplest case is an explicit list: |
55 | for my ($q, $r) ('A', 'B', 'C', 'D') { | |
56 | push @have, "$q;$r"; | |
57 | } | |
58 | is("@have", 'A;B C;D', 'explicit list'); | |
59 | ||
60 | @have = (); | |
61 | ||
62 | for my ($q, $r) (reverse 'A', 'B', 'C', 'D') { | |
63 | push @have, "$q;$r"; | |
64 | } | |
65 | is("@have", 'D;C B;A', 'explicit list reversed'); | |
66 | ||
67 | @have = (); | |
68 | ||
69 | for my ($q, $r) ('A', 'B', 'C', 'D', 'E', 'F') { | |
70 | push @have, "$q;$r"; | |
71 | } | |
72 | is("@have", 'A;B C;D E;F', 'explicit list three iterations'); | |
73 | ||
74 | @have = (); | |
75 | ||
76 | for my ($q, $r, $s) ('A', 'B', 'C', 'D', 'E', 'F') { | |
77 | push @have, "$q;$r;$s"; | |
78 | } | |
79 | is("@have", 'A;B;C D;E;F', 'explicit list triplets'); | |
80 | ||
81 | @have = (); | |
82 | ||
83 | for my ($q, $r, $s,) ('A', 'B', 'C', 'D', 'E', 'F') { | |
84 | push @have, "$q;$r;$s"; | |
85 | } | |
86 | is("@have", 'A;B;C D;E;F', 'trailing comma n-fold'); | |
87 | ||
88 | @have = (); | |
89 | ||
90 | for my ($q, $r, $s) ('A', 'B', 'C', 'D', 'E') { | |
91 | push @have, join ';', map { $_ // 'undef' } $q, $r, $s; | |
92 | } | |
93 | ||
94 | is("@have", 'A;B;C D;E;undef', 'incomplete explicit list'); | |
95 | ||
96 | @have = (); | |
97 | ||
98 | for my ($q, $r, $s) (reverse 'A', 'B', 'C', 'D', 'E') { | |
99 | push @have, join ';', map { $_ // 'undef' } $q, $r, $s; | |
100 | } | |
101 | ||
102 | is("@have", 'E;D;C B;A;undef', 'incomplete explicit list reversed'); | |
103 | ||
104 | # This two are legal syntax and actually indistinguishable from for my $q () ... | |
105 | @have = (); | |
106 | ||
107 | for my ($q,) ('A', 'B', 'C', 'D', 'E', 'F') { | |
108 | push @have, $q; | |
109 | } | |
110 | is("@have", 'A B C D E F', 'trailing comma one-at-a-time'); | |
111 | ||
112 | @have = (); | |
113 | ||
114 | for my ($q) ('A', 'B', 'C', 'D', 'E', 'F') { | |
115 | push @have, $q; | |
116 | } | |
117 | is("@have", 'A B C D E F', 'one-at-a-time'); | |
118 | ||
119 | ||
120 | # Arrays have an optimised case in pp_iter: | |
121 | { | |
ebb7bd1b | 122 | no strict 'vars'; |
83c7d349 NC |
123 | |
124 | @array = split ' ', 'Dogs have owners, cats have staff.'; | |
125 | ||
126 | my $count = scalar @array; | |
127 | ||
128 | @have = (); | |
129 | ||
130 | for my ($q, $r, $s) (@array) { | |
131 | push @have, "$q;$r;$s"; | |
132 | } | |
133 | is("@have", 'Dogs;have;owners, cats;have;staff.', 'package array'); | |
134 | is(scalar @array, $count, 'package array size unchanged'); | |
135 | ||
136 | @have = (); | |
137 | ||
138 | for my ($q, $r, $s) (reverse @array) { | |
139 | push @have, "$q;$r;$s"; | |
140 | } | |
141 | is("@have", 'staff.;have;cats owners,;have;Dogs', 'package array reversed'); | |
142 | is(scalar @array, $count, 'package array reversed size unchanged'); | |
143 | ||
144 | @have = (); | |
145 | ||
146 | for my ($q, $r, $s, $t) (@array) { | |
147 | push @have, join ';', map { $_ // '!' } $q, $r, $s, $t; | |
148 | } | |
149 | is("@have", 'Dogs;have;owners,;cats have;staff.;!;!', 'incomplete package array'); | |
150 | ||
151 | @have = (); | |
152 | ||
153 | for my ($q, $r, $s, $t) (reverse @array) { | |
154 | push @have, join ';', map { $_ // '!' } $q, $r, $s, $t; | |
155 | } | |
156 | is("@have", 'staff.;have;cats;owners, have;Dogs;!;!', 'incomplete package array reversed'); | |
157 | is(scalar @array, $count, 'incomplete package array size unchanged'); | |
158 | ||
159 | # And for our last test, we trash @array | |
160 | for my ($q, $r) (@array) { | |
161 | ($q, $r) = ($r, $q); | |
162 | } | |
163 | is("@array", 'have Dogs cats owners, staff. have', 'package array aliased'); | |
164 | is(scalar @array, $count, 'incomplete package array reversed size unchanged'); | |
165 | } | |
166 | ||
167 | my @array = split ' ', 'God is real, unless declared integer.'; | |
168 | ||
169 | my $count = scalar @array; | |
170 | ||
171 | @have = (); | |
172 | ||
173 | for my ($q, $r, $s) (@array) { | |
174 | push @have, "$q;$r;$s"; | |
175 | } | |
176 | is("@have", 'God;is;real, unless;declared;integer.', 'lexical array'); | |
177 | is(scalar @array, $count, 'lexical array size unchanged'); | |
178 | ||
179 | @have = (); | |
180 | ||
181 | for my ($q, $r, $s) (reverse @array) { | |
182 | push @have, "$q;$r;$s"; | |
183 | } | |
184 | is("@have", 'integer.;declared;unless real,;is;God', 'lexical array reversed'); | |
185 | is(scalar @array, $count, 'lexical array reversed size unchanged'); | |
186 | ||
187 | @have = (); | |
188 | ||
189 | for my ($q, $r, $s, $t) (@array) { | |
190 | push @have, join ';', map { $_ // '!' } $q, $r, $s, $t; | |
191 | } | |
192 | is("@have", 'God;is;real,;unless declared;integer.;!;!', 'incomplete lexical array'); | |
193 | is(scalar @array, $count, 'incomplete lexical array size unchanged'); | |
194 | ||
195 | @have = (); | |
196 | ||
197 | for my ($q, $r, $s, $t) (reverse @array) { | |
198 | push @have, join ';', map { $_ // '!' } $q, $r, $s, $t; | |
199 | } | |
200 | is("@have", 'integer.;declared;unless;real, is;God;!;!', 'incomplete lexical array reversed'); | |
201 | is(scalar @array, $count, 'incomplete lexical array reversed size unchanged'); | |
202 | ||
203 | for my ($q, $r) (@array) { | |
204 | $q = uc $q; | |
205 | $r = ucfirst $r; | |
206 | } | |
207 | is("@array", 'GOD Is REAL, Unless DECLARED Integer.', 'lexical array aliased'); | |
208 | ||
209 | # Integer ranges have an optimised case in pp_iter: | |
210 | @have = (); | |
211 | ||
212 | for my ($q, $r, $s) (0..5) { | |
213 | push @have, "$q;$r;$s"; | |
214 | } | |
215 | ||
216 | is("@have", '0;1;2 3;4;5', 'integer list'); | |
217 | ||
218 | @have = (); | |
219 | ||
220 | for my ($q, $r, $s) (reverse 0..5) { | |
221 | push @have, "$q;$r;$s"; | |
222 | } | |
223 | ||
224 | is("@have", '5;4;3 2;1;0', 'integer list reversed'); | |
225 | ||
226 | @have = (); | |
227 | ||
228 | for my ($q, $r, $s) (1..5) { | |
229 | push @have, join ';', map { $_ // 'undef' } $q, $r, $s; | |
230 | } | |
231 | ||
232 | is("@have", '1;2;3 4;5;undef', 'incomplete integer list'); | |
233 | ||
234 | @have = (); | |
235 | ||
236 | for my ($q, $r, $s) (reverse 1..5) { | |
237 | push @have, join ';', map { $_ // 'Thunderbirds are go' } $q, $r, $s; | |
238 | } | |
239 | ||
240 | is("@have", '5;4;3 2;1;Thunderbirds are go', 'incomplete integer list reversed'); | |
241 | ||
242 | # String ranges have an optimised case in pp_iter: | |
243 | @have = (); | |
244 | ||
245 | for my ($q, $r, $s) ('A'..'F') { | |
246 | push @have, "$q;$r;$s"; | |
247 | } | |
248 | ||
249 | is("@have", 'A;B;C D;E;F', 'string list'); | |
250 | ||
251 | @have = (); | |
252 | ||
253 | for my ($q, $r, $s) (reverse 'A'..'F') { | |
254 | push @have, "$q;$r;$s"; | |
255 | } | |
256 | ||
257 | is("@have", 'F;E;D C;B;A', 'string list reversed'); | |
258 | ||
259 | @have = (); | |
260 | ||
261 | for my ($q, $r, $s) ('B'..'F') { | |
262 | push @have, join ';', map { $_ // 'undef' } $q, $r, $s; | |
263 | } | |
264 | ||
265 | is("@have", 'B;C;D E;F;undef', 'incomplete string list'); | |
266 | ||
267 | @have = (); | |
268 | ||
269 | for my ($q, $r, $s) (reverse 'B'..'F') { | |
270 | push @have, join ';', map { $_ // 'undef' } $q, $r, $s; | |
271 | } | |
272 | ||
273 | is("@have", 'F;E;D C;B;undef', 'incomplete string list reversed'); | |
274 | ||
275 | # Hashes are expanded as regular lists, so there's nothing particularly | |
276 | # special here: | |
277 | { | |
278 | no strict; | |
279 | ||
280 | %hash = ( | |
281 | perl => 'rules', | |
282 | beer => 'foamy', | |
283 | ); | |
284 | ||
285 | @have = (); | |
286 | ||
287 | for my ($key, $value) (%hash) { | |
288 | push @have, "$key;$value"; | |
289 | } | |
290 | ||
291 | my $got = "@have"; | |
292 | if ($got =~ /^perl/) { | |
293 | is($got, 'perl;rules beer;foamy', 'package hash key/value iteration'); | |
294 | } | |
295 | else { | |
296 | is($got, 'beer;foamy perl;rules', 'package hash key/value iteration'); | |
297 | } | |
298 | ||
299 | @have = (); | |
300 | ||
301 | for my ($value, $key) (reverse %hash) { | |
302 | push @have, "$key;$value"; | |
303 | } | |
304 | ||
305 | $got = "@have"; | |
306 | if ($got =~ /^perl/) { | |
307 | is($got, 'perl;rules beer;foamy', 'package hash key/value reverse iteration'); | |
308 | } | |
309 | else { | |
310 | is($got, 'beer;foamy perl;rules', 'package hash key/value reverse iteration'); | |
311 | } | |
312 | ||
313 | # values are aliases. As ever. Keys are copies. | |
314 | ||
315 | for my ($key, $value) (%hash) { | |
316 | $key = ucfirst $key; | |
317 | $value = uc $value; | |
318 | } | |
319 | ||
320 | $got = join ';', %hash; | |
321 | ||
322 | if ($got =~ /^perl/i) { | |
323 | is($got, 'perl;RULES;beer;FOAMY', 'package hash value iteration aliases'); | |
324 | } | |
325 | else { | |
326 | is($got, 'beer;FOAMY;perl;RULES', 'package hash value iteration aliases'); | |
327 | } | |
328 | } | |
329 | ||
330 | my %hash = ( | |
331 | beer => 'street', | |
332 | gin => 'lane', | |
333 | ); | |
334 | ||
335 | ||
336 | @have = (); | |
337 | ||
338 | for my ($key, $value) (%hash) { | |
339 | push @have, "$key;$value"; | |
340 | } | |
341 | ||
342 | my $got = "@have"; | |
343 | if ($got =~ /^gin/) { | |
344 | is($got, 'gin;lane beer;street', 'lexical hash key/value iteration'); | |
345 | } | |
346 | else { | |
347 | is($got, 'beer;street gin;lane', 'lexical hash key/value iteration'); | |
348 | } | |
349 | ||
350 | @have = (); | |
351 | ||
352 | for my ($value, $key) (reverse %hash) { | |
353 | push @have, "$key;$value"; | |
354 | } | |
355 | ||
356 | $got = "@have"; | |
357 | if ($got =~ /^gin/) { | |
358 | is($got, 'gin;lane beer;street', 'lexical hash key/value reverse iteration'); | |
359 | } | |
360 | else { | |
361 | is($got, 'beer;street gin;lane', 'lexical hash key/value reverse iteration'); | |
362 | } | |
363 | ||
364 | # values are aliases, keys are copies, so this is a daft thing to do: | |
365 | ||
366 | for my ($key, $value) (%hash) { | |
367 | ($key, $value) = ($value, $key); | |
368 | } | |
369 | ||
370 | $got = join ';', %hash; | |
371 | ||
372 | if ($got =~ /^gin/i) { | |
373 | is($got, 'gin;gin;beer;beer', 'lexical hash value iteration aliases'); | |
374 | } | |
375 | else { | |
376 | is($got, 'beer;beer;gin;gin', 'lexical hash value iteration aliases'); | |
377 | } | |
378 | ||
379 | my $code = 'for my ($q, $r) (6, 9) {}; 42'; | |
380 | ||
381 | $got = eval $code; | |
382 | ||
383 | is($@, "", 'test code generated no error'); | |
384 | is($got, 42, 'test code ran'); | |
385 | ||
386 | $code =~ s/my/our/; | |
387 | ||
388 | like($code, qr/for our \(/, 'for our code set up correctly'); | |
389 | $got = eval $code; | |
390 | ||
391 | like($@, qr/^Missing \$ on loop variable /, 'for our code generated error'); | |
392 | is($got, undef, 'for our did not run'); | |
393 | ||
394 | $code =~ s/ our//; | |
395 | ||
396 | like($code, qr/for \(/, 'for () () code set up correctly'); | |
397 | $got = eval "no strict 'vars'; $code"; | |
398 | ||
399 | like($@, qr/^syntax error /, 'for () () code generated error'); | |
400 | is($got, undef, 'for () () did not run'); | |
401 | ||
b1ed6316 NC |
402 | # Yes, I looked these up: |
403 | my @Quercus = qw(robor petraea cerris); | |
404 | # I should be able to sneak this past the children for some years... | |
405 | my @Allium = qw(cepa sativum ampeloprasum); | |
406 | ||
407 | for my ($left, $right) (@Quercus, @Allium) { | |
408 | $left = uc $left; | |
409 | $right = reverse $right; | |
410 | } | |
411 | ||
412 | is("@Quercus", 'ROBOR aeartep CERRIS', 'for () () aliases 1'); | |
413 | is("@Allium", 'apec SATIVUM musarpolepma', 'for () () aliases 2'); | |
414 | ||
415 | is(eval { | |
416 | for my ($left, $right) (@Allium, undef, @Quercus) { | |
417 | $left = reverse $left; | |
418 | $right = lc($right // ""); | |
419 | } | |
420 | 54; | |
421 | }, undef, 'aliased rvalue'); | |
422 | like($@, qr/^Modification of a read-only value attempted/, | |
423 | 'aliased rvalue threw the correct exception'); | |
424 | ||
425 | is("@Allium", 'cepa sativum ampeloprasum', 'for () () aliases 3'); | |
426 | is("@Quercus", 'ROBOR aeartep CERRIS', 'for () () aliases 4'); | |
427 | ||
428 | is(eval { | |
429 | for my ($left, $right) (@Quercus) { | |
430 | $left = lc $left; | |
431 | $right = reverse($right // ""); | |
432 | } | |
433 | 54; | |
434 | }, undef, 'padded with literal undef'); | |
435 | like($@, qr/^Modification of a read-only value attempted/, | |
436 | 'padded with literal undef threw the correct exception'); | |
437 | is("@Quercus", 'robor petraea cerris', 'side effects observed'); | |
438 | ||
439 | my @numbers = (3, 2, 1, 0); | |
440 | my $redo; | |
441 | my $next; | |
442 | my $done; | |
443 | my $continue; | |
444 | ||
445 | for my ($left, $right) (@numbers) { | |
446 | $left *= 3; | |
447 | ++$right; | |
448 | redo | |
449 | unless $redo++; | |
450 | ++$done; | |
451 | next | |
452 | unless $next++; | |
453 | $left *= 5; | |
454 | $right *= 7; | |
455 | } continue { | |
456 | $continue .= 'x'; | |
457 | } | |
458 | ||
459 | is("@numbers", '27 4 15 7', 'expected result'); | |
460 | is($redo, 3, 'redo reached thrice'); | |
461 | is($next, 2, 'next reached twice'); | |
462 | is($continue, 'xx', 'continue reached twice'); | |
463 | ||
ebb7bd1b NC |
464 | { |
465 | no strict 'vars'; | |
466 | # Important that this is a package variable, so that we test that the parser | |
467 | # ends the scope of the my at the ')' and generates the correct ops to read | |
468 | # from the symbol table, not the pad. | |
469 | ||
470 | @Lamini = qw(alpaca guanaco llama vicuña); | |
471 | ||
472 | @have = (); | |
473 | for my ($domestic, $wild) (@Lamini) { | |
474 | push @have, "$domestic;$wild"; | |
475 | } | |
476 | is("@have", 'alpaca;guanaco llama;vicuña', 'comma test 0'); | |
477 | ||
478 | @have = (); | |
479 | for my ($domestic, $wild,) (@Lamini) { | |
480 | push @have, "$domestic;$wild"; | |
481 | } | |
482 | is("@have", 'alpaca;guanaco llama;vicuña', 'comma test 1'); | |
483 | ||
484 | @have = (); | |
485 | for my ($domestic,, $wild) (@Lamini) { | |
486 | push @have, "$domestic;$wild"; | |
487 | } | |
488 | is("@have", 'alpaca;guanaco llama;vicuña', 'comma test 2'); | |
489 | ||
490 | @have = (); | |
491 | for my ($domestic,, $wild,) (@Lamini) { | |
492 | push @have, "$domestic;$wild"; | |
493 | } | |
494 | is("@have", 'alpaca;guanaco llama;vicuña', 'comma test 3'); | |
495 | ||
496 | @have = (); | |
497 | for my ($domestic,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, $wild) (@Lamini) { | |
498 | push @have, "$domestic;$wild"; | |
499 | } | |
500 | is("@have", 'alpaca;guanaco llama;vicuña', 'comma test 42'); | |
501 | } | |
502 | ||
bd09be5b NC |
503 | # Spaces shouldn't trigger parsing errors: |
504 | { | |
505 | my @correct = ('Pointy', 'Up', 'Flamey', 'Down'); | |
506 | ||
507 | @have = (); | |
508 | ||
509 | for my ($one) (@correct) { | |
510 | push @have, $one; | |
511 | } | |
512 | is("@have", "@correct", 'for my ($one)'); | |
513 | ||
514 | @have = (); | |
515 | ||
516 | for my($one) (@correct) { | |
517 | push @have, $one; | |
518 | } | |
519 | is("@have", "@correct", 'for my($one)'); | |
520 | ||
521 | @have = (); | |
522 | ||
523 | # This is lots of lovely whitespace: | |
524 | for my | |
525 | ($end, $orientation) (@correct) { | |
526 | push @have, "$end end $orientation"; | |
527 | } | |
528 | is("@have", "Pointy end Up Flamey end Down", 'for my ($one, $two)'); | |
529 | ||
530 | @have = (); | |
531 | ||
532 | for my($end, $orientation) (@correct) { | |
533 | push @have, "$end end $orientation"; | |
534 | } | |
535 | is("@have", "Pointy end Up Flamey end Down", 'for my ($one, $two)'); | |
536 | } | |
537 | ||
83c7d349 | 538 | done_testing(); |