Commit | Line | Data |
---|---|---|
87a42246 MS |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
62a6bb71 | 4 | unshift @INC, 't'; |
9cd8f857 NC |
5 | require Config; |
6 | if (($Config::Config{'extensions'} !~ /\bB\b/) ){ | |
7 | print "1..0 # Skip -- Perl configured without B module\n"; | |
8 | exit 0; | |
9 | } | |
87a42246 MS |
10 | } |
11 | ||
87a42246 MS |
12 | use warnings; |
13 | use strict; | |
507a68aa | 14 | use Test::More; |
87a42246 | 15 | |
7741ceed | 16 | my $tests = 25; # not counting those in the __DATA__ section |
3036b99c | 17 | |
87a42246 | 18 | use B::Deparse; |
09d856fb | 19 | my $deparse = B::Deparse->new(); |
507a68aa | 20 | isa_ok($deparse, 'B::Deparse', 'instantiate a B::Deparse object'); |
4da9a2ca | 21 | my %deparse; |
87a42246 | 22 | |
ad46c0be RH |
23 | $/ = "\n####\n"; |
24 | while (<DATA>) { | |
25 | chomp; | |
d8cf01c3 | 26 | $tests ++; |
e9c69003 NC |
27 | # This code is pinched from the t/lib/common.pl for TODO. |
28 | # It's not clear how to avoid duplication | |
a6087f24 | 29 | my %meta = (context => ''); |
4da9a2ca | 30 | foreach my $what (qw(skip todo context options)) { |
c4a350e6 | 31 | s/^#\s*\U$what\E\s*(.*)\n//m and $meta{$what} = $1; |
b871937f NC |
32 | # If the SKIP reason starts ? then it's taken as a code snippet to |
33 | # evaluate. This provides the flexibility to have conditional SKIPs | |
c4a350e6 NC |
34 | if ($meta{$what} && $meta{$what} =~ s/^\?//) { |
35 | my $temp = eval $meta{$what}; | |
b871937f | 36 | if ($@) { |
c4a350e6 | 37 | die "# In \U$what\E code reason:\n# $meta{$what}\n$@"; |
b871937f | 38 | } |
c4a350e6 | 39 | $meta{$what} = $temp; |
e9c69003 | 40 | } |
e9c69003 NC |
41 | } |
42 | ||
4a4b8592 | 43 | s/^\s*#\s*(.*)$//mg; |
507a68aa NC |
44 | my $desc = $1; |
45 | die "Missing name in test $_" unless defined $desc; | |
e9c69003 | 46 | |
c4a350e6 | 47 | if ($meta{skip}) { |
e9c69003 | 48 | # Like this to avoid needing a label SKIP: |
c4a350e6 | 49 | Test::More->builder->skip($meta{skip}); |
e9c69003 NC |
50 | next; |
51 | } | |
52 | ||
ad46c0be RH |
53 | my ($input, $expected); |
54 | if (/(.*)\n>>>>\n(.*)/s) { | |
55 | ($input, $expected) = ($1, $2); | |
56 | } | |
57 | else { | |
58 | ($input, $expected) = ($_, $_); | |
59 | } | |
87a42246 | 60 | |
4da9a2ca FC |
61 | # parse options if necessary |
62 | my $deparse = $meta{options} | |
63 | ? $deparse{$meta{options}} ||= | |
64 | new B::Deparse split /,/, $meta{options} | |
65 | : $deparse; | |
66 | ||
a6087f24 NC |
67 | my $coderef = eval "$meta{context};\n" . <<'EOC' . "sub {$input}"; |
68 | # Tell B::Deparse about our ambient pragmas | |
69 | my ($hint_bits, $warning_bits, $hinthash); | |
70 | BEGIN { | |
71 | ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); | |
72 | } | |
73 | $deparse->ambient_pragmas ( | |
74 | hint_bits => $hint_bits, | |
75 | warning_bits => $warning_bits, | |
76 | '%^H' => $hinthash, | |
77 | ); | |
78 | EOC | |
87a42246 | 79 | |
ad46c0be | 80 | if ($@) { |
507a68aa | 81 | is($@, "", "compilation of $desc"); |
ad46c0be RH |
82 | } |
83 | else { | |
84 | my $deparsed = $deparse->coderef2text( $coderef ); | |
31c6271a RD |
85 | my $regex = $expected; |
86 | $regex =~ s/(\S+)/\Q$1/g; | |
87 | $regex =~ s/\s+/\\s+/g; | |
88 | $regex = '^\{\s*' . $regex . '\s*\}$'; | |
b871937f | 89 | |
c4a350e6 | 90 | local $::TODO = $meta{todo}; |
507a68aa | 91 | like($deparsed, qr/$regex/, $desc); |
87a42246 | 92 | } |
87a42246 MS |
93 | } |
94 | ||
87a42246 | 95 | use constant 'c', 'stuff'; |
507a68aa NC |
96 | is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff', |
97 | 'the subroutine generated by use constant deparses'); | |
87a42246 | 98 | |
09d856fb | 99 | my $a = 0; |
507a68aa NC |
100 | is($deparse->coderef2text(sub{(-1) ** $a }), "{\n (-1) ** \$a;\n}", |
101 | 'anon sub capturing an external lexical'); | |
87a42246 | 102 | |
d989cdac SM |
103 | use constant cr => ['hello']; |
104 | my $string = "sub " . $deparse->coderef2text(\&cr); | |
0707d6cc | 105 | my $val = (eval $string)->() or diag $string; |
507a68aa NC |
106 | is(ref($val), 'ARRAY', 'constant array references deparse'); |
107 | is($val->[0], 'hello', 'and return the correct value'); | |
87a42246 | 108 | |
87a42246 | 109 | my $path = join " ", map { qq["-I$_"] } @INC; |
87a42246 | 110 | |
7cde0a5f | 111 | $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 2>&1`; |
e69a2255 | 112 | $a =~ s/-e syntax OK\n//g; |
d2bc402e | 113 | $a =~ s/.*possible typo.*\n//; # Remove warning line |
82f96200 | 114 | $a =~ s/.*-i used with no filenames.*\n//; # Remove warning line |
87a42246 MS |
115 | $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037 |
116 | $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc' | |
117 | $b = <<'EOF'; | |
d2bc402e RGS |
118 | BEGIN { $^I = ".bak"; } |
119 | BEGIN { $^W = 1; } | |
120 | BEGIN { $/ = "\n"; $\ = "\n"; } | |
87a42246 MS |
121 | LINE: while (defined($_ = <ARGV>)) { |
122 | chomp $_; | |
f86ea535 | 123 | our(@F) = split(' ', $_, 0); |
87a42246 MS |
124 | '???'; |
125 | } | |
87a42246 | 126 | EOF |
507a68aa NC |
127 | is($a, $b, |
128 | 'command line flags deparse as BEGIN blocks setting control variables'); | |
87a42246 | 129 | |
5b4ee549 NC |
130 | $a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`; |
131 | $a =~ s/-e syntax OK\n//g; | |
132 | is($a, "use constant ('PI', 4);\n", | |
133 | "Proxy Constant Subroutines must not show up as (incorrect) prototypes"); | |
134 | ||
579a54dc | 135 | #Re: perlbug #35857, patch #24505 |
b3980c39 YO |
136 | #handle warnings::register-ed packages properly. |
137 | package B::Deparse::Wrapper; | |
138 | use strict; | |
139 | use warnings; | |
140 | use warnings::register; | |
141 | sub getcode { | |
579a54dc | 142 | my $deparser = B::Deparse->new(); |
b3980c39 YO |
143 | return $deparser->coderef2text(shift); |
144 | } | |
145 | ||
2990415a FR |
146 | package Moo; |
147 | use overload '0+' => sub { 42 }; | |
148 | ||
b3980c39 YO |
149 | package main; |
150 | use strict; | |
151 | use warnings; | |
71c4dbc3 | 152 | use constant GLIPP => 'glipp'; |
2990415a FR |
153 | use constant PI => 4; |
154 | use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo'); | |
3779476a | 155 | use Fcntl qw/O_TRUNC O_APPEND O_EXCL/; |
aaf9c2b2 | 156 | BEGIN { delete $::Fcntl::{O_APPEND}; } |
2990415a | 157 | use POSIX qw/O_CREAT/; |
b3980c39 | 158 | sub test { |
579a54dc RGS |
159 | my $val = shift; |
160 | my $res = B::Deparse::Wrapper::getcode($val); | |
507a68aa NC |
161 | like($res, qr/use warnings/, |
162 | '[perl #35857] [PATCH] B::Deparse doesnt handle warnings register properly'); | |
b3980c39 YO |
163 | } |
164 | my ($q,$p); | |
165 | my $x=sub { ++$q,++$p }; | |
166 | test($x); | |
167 | eval <<EOFCODE and test($x); | |
168 | package bar; | |
169 | use strict; | |
170 | use warnings; | |
171 | use warnings::register; | |
172 | package main; | |
173 | 1 | |
174 | EOFCODE | |
175 | ||
d1dc589d FC |
176 | # Exotic sub declarations |
177 | $a = `$^X $path "-MO=Deparse" -e "sub ::::{}sub ::::::{}" 2>&1`; | |
178 | $a =~ s/-e syntax OK\n//g; | |
179 | is($a, <<'EOCODG', "sub :::: and sub ::::::"); | |
180 | sub :::: { | |
181 | ||
182 | } | |
183 | sub :::::: { | |
184 | ||
185 | } | |
186 | EOCODG | |
187 | ||
f2734596 HE |
188 | # [perl #117311] |
189 | $a = `$^X $path "-MO=Deparse,-l" -e "map{ eval(0) }()" 2>&1`; | |
190 | $a =~ s/-e syntax OK\n//g; | |
191 | is($a, <<'EOCODH', "[perl #117311] [PATCH] -l option ('#line ...') does not emit ^Ls in the output"); | |
192 | #line 1 "-e" | |
193 | map { | |
194 | #line 1 "-e" | |
195 | eval 0;} (); | |
196 | EOCODH | |
197 | ||
640d5d41 FC |
198 | # [perl #33752] |
199 | { | |
200 | my $code = <<"EOCODE"; | |
201 | { | |
202 | our \$\x{1e1f}\x{14d}\x{14d}; | |
203 | } | |
204 | EOCODE | |
205 | my $deparsed | |
206 | = $deparse->coderef2text(eval "sub { our \$\x{1e1f}\x{14d}\x{14d} }" ); | |
207 | s/$ \n//x for $deparsed, $code; | |
208 | is $deparsed, $code, 'our $funny_Unicode_chars'; | |
209 | } | |
210 | ||
bdabb2d5 FC |
211 | # [perl #62500] |
212 | $a = | |
213 | `$^X $path "-MO=Deparse" -e "BEGIN{*CORE::GLOBAL::require=sub{1}}" 2>&1`; | |
214 | $a =~ s/-e syntax OK\n//g; | |
215 | is($a, <<'EOCODF', "CORE::GLOBAL::require override causing panick"); | |
216 | sub BEGIN { | |
217 | *CORE::GLOBAL::require = sub { | |
218 | 1; | |
219 | } | |
220 | ; | |
221 | } | |
222 | EOCODF | |
223 | ||
894e98ac FC |
224 | # [perl #91384] |
225 | $a = | |
226 | `$^X $path "-MO=Deparse" -e "BEGIN{*Acme::Acme:: = *Acme::}" 2>&1`; | |
227 | like($a, qr/-e syntax OK/, | |
228 | "Deparse does not hang when traversing stash circularities"); | |
229 | ||
bb8996b8 | 230 | # [perl #93990] |
08412a26 NC |
231 | @] = (); |
232 | is($deparse->coderef2text(sub{ print "@{]}" }), | |
bb8996b8 | 233 | q<{ |
08412a26 NC |
234 | print "@{]}"; |
235 | }>, 'curly around to interpolate "@{]}"'); | |
bb8996b8 HY |
236 | is($deparse->coderef2text(sub{ print "@{-}" }), |
237 | q<{ | |
238 | print "@-"; | |
239 | }>, 'no need to curly around to interpolate "@-"'); | |
240 | ||
1c74777c FC |
241 | # Strict hints in %^H are mercilessly suppressed |
242 | $a = | |
243 | `$^X $path "-MO=Deparse" -e "use strict; print;" 2>&1`; | |
244 | unlike($a, qr/BEGIN/, | |
245 | "Deparse does not emit strict hh hints"); | |
246 | ||
3036b99c FC |
247 | # ambient_pragmas should not mess with strict settings. |
248 | SKIP: { | |
249 | skip "requires 5.11", 1 unless $] >= 5.011; | |
250 | eval q` | |
3036b99c | 251 | BEGIN { |
d1718a7c | 252 | # Clear out all hints |
3036b99c | 253 | %^H = (); |
d1718a7c | 254 | $^H = 0; |
3036b99c FC |
255 | new B::Deparse -> ambient_pragmas(strict => 'all'); |
256 | } | |
257 | use 5.011; # should enable strict | |
258 | ok !eval '$do_noT_create_a_variable_with_this_name = 1', | |
259 | 'ambient_pragmas do not mess with compiling scope'; | |
260 | `; | |
261 | } | |
262 | ||
93a8ff62 FC |
263 | # multiple statements on format lines |
264 | $a = `$^X $path "-MO=Deparse" -e "format =" -e "\@" -e "x();z()" -e. 2>&1`; | |
265 | $a =~ s/-e syntax OK\n//g; | |
93a8ff62 FC |
266 | is($a, <<'EOCODH', 'multiple statements on format lines'); |
267 | format STDOUT = | |
268 | @ | |
269 | x(); z() | |
270 | . | |
271 | EOCODH | |
272 | ||
7741ceed FC |
273 | # CORE::format |
274 | $a = readpipe qq`$^X $path "-MO=Deparse" -e "use feature q|:all|;` | |
275 | .qq` my sub format; CORE::format =" -e. 2>&1`; | |
276 | like($a, qr/CORE::format/, 'CORE::format when lex format sub is in scope'); | |
277 | ||
fea7fb25 DM |
278 | # literal big chars under 'use utf8' |
279 | is($deparse->coderef2text(sub{ use utf8; /€/; }), | |
280 | '{ | |
281 | /\x{20ac}/; | |
282 | }', | |
283 | "qr/euro/"); | |
284 | ||
e54915d6 FC |
285 | # STDERR when deparsing sub calls |
286 | # For a short while the output included 'While deparsing' | |
287 | $a = `$^X $path "-MO=Deparse" -e "foo()" 2>&1`; | |
288 | $a =~ s/-e syntax OK\n//g; | |
289 | is($a, <<'EOCODI', 'no extra output when deparsing foo()'); | |
290 | foo(); | |
291 | EOCODI | |
292 | ||
7741ceed FC |
293 | # CORE::no |
294 | $a = readpipe qq`$^X $path "-MO=Deparse" -Xe ` | |
295 | .qq`"use feature q|:all|; my sub no; CORE::no less" 2>&1`; | |
296 | like($a, qr/my sub no;\n\(\);\nCORE::no less;/, | |
297 | 'CORE::no after my sub no'); | |
298 | ||
299 | # CORE::use | |
300 | $a = readpipe qq`$^X $path "-MO=Deparse" -Xe ` | |
301 | .qq`"use feature q|:all|; my sub use; CORE::use less" 2>&1`; | |
302 | like($a, qr/my sub use;\n\(\);\nCORE::use less;/, | |
303 | 'CORE::use after my sub use'); | |
304 | ||
305 | # CORE::__DATA__ | |
306 | $a = readpipe qq`$^X $path "-MO=Deparse" -Xe ` | |
307 | .qq`"use feature q|:all|; my sub __DATA__; ` | |
308 | .qq`CORE::__DATA__" 2>&1`; | |
309 | like($a, qr/my sub __DATA__;\n\(\);\nCORE::__DATA__/, | |
310 | 'CORE::__DATA__ after my sub __DATA__'); | |
311 | ||
93a8ff62 | 312 | |
d8cf01c3 | 313 | done_testing($tests); |
507a68aa | 314 | |
ad46c0be | 315 | __DATA__ |
b8346d05 KW |
316 | # TODO [perl #120950] This succeeds when run a 2nd time |
317 | # y/uni/code/ | |
318 | tr/\x{345}/\x{370}/; | |
319 | #### | |
320 | # y/uni/code/ [perl #120950] This 2nd instance succeeds | |
321 | tr/\x{345}/\x{370}/; | |
322 | #### | |
507a68aa | 323 | # A constant |
ad46c0be RH |
324 | 1; |
325 | #### | |
507a68aa | 326 | # Constants in a block |
ad46c0be RH |
327 | { |
328 | no warnings; | |
329 | '???'; | |
330 | 2; | |
331 | } | |
332 | #### | |
507a68aa | 333 | # Lexical and simple arithmetic |
ad46c0be RH |
334 | my $test; |
335 | ++$test and $test /= 2; | |
336 | >>>> | |
337 | my $test; | |
338 | $test /= 2 if ++$test; | |
339 | #### | |
507a68aa | 340 | # list x |
ad46c0be RH |
341 | -((1, 2) x 2); |
342 | #### | |
507a68aa | 343 | # lvalue sub |
ad46c0be RH |
344 | { |
345 | my $test = sub : lvalue { | |
346 | my $x; | |
347 | } | |
348 | ; | |
349 | } | |
350 | #### | |
507a68aa | 351 | # method |
ad46c0be RH |
352 | { |
353 | my $test = sub : method { | |
354 | my $x; | |
355 | } | |
356 | ; | |
357 | } | |
358 | #### | |
507a68aa | 359 | # block with continue |
87a42246 | 360 | { |
ad46c0be | 361 | 234; |
f99a63a2 | 362 | } |
ad46c0be RH |
363 | continue { |
364 | 123; | |
87a42246 | 365 | } |
ce4e655d | 366 | #### |
507a68aa | 367 | # lexical and package scalars |
ce4e655d RH |
368 | my $x; |
369 | print $main::x; | |
370 | #### | |
507a68aa | 371 | # lexical and package arrays |
ce4e655d RH |
372 | my @x; |
373 | print $main::x[1]; | |
14a55f98 | 374 | #### |
507a68aa | 375 | # lexical and package hashes |
14a55f98 RH |
376 | my %x; |
377 | $x{warn()}; | |
ad8caead | 378 | #### |
66786896 FC |
379 | # our (LIST) |
380 | our($foo, $bar, $baz); | |
381 | #### | |
56cd2ef8 FC |
382 | # CONTEXT { package Dog } use feature "state"; |
383 | # variables with declared classes | |
384 | my Dog $spot; | |
385 | our Dog $spotty; | |
386 | state Dog $spotted; | |
387 | my Dog @spot; | |
388 | our Dog @spotty; | |
389 | state Dog @spotted; | |
390 | my Dog %spot; | |
391 | our Dog %spotty; | |
392 | state Dog %spotted; | |
393 | my Dog ($foo, @bar, %baz); | |
394 | our Dog ($phoo, @barr, %bazz); | |
395 | state Dog ($fough, @barre, %bazze); | |
396 | #### | |
f3515641 FC |
397 | # local our |
398 | local our $rhubarb; | |
5f4d8496 | 399 | local our($rhu, $barb); |
f3515641 | 400 | #### |
507a68aa | 401 | # <> |
ad8caead RGS |
402 | my $foo; |
403 | $_ .= <ARGV> . <$foo>; | |
cef22867 | 404 | #### |
507a68aa | 405 | # \x{} |
11454c59 | 406 | my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ"; |
4ae52e81 | 407 | #### |
507a68aa | 408 | # s///e |
4ae52e81 | 409 | s/x/'y';/e; |
ef90d20a FC |
410 | s/x/$a;/e; |
411 | s/x/complex_expression();/e; | |
241416b8 | 412 | #### |
507a68aa | 413 | # block |
241416b8 DM |
414 | { my $x; } |
415 | #### | |
507a68aa | 416 | # while 1 |
241416b8 DM |
417 | while (1) { my $k; } |
418 | #### | |
507a68aa | 419 | # trailing for |
241416b8 DM |
420 | my ($x,@a); |
421 | $x=1 for @a; | |
422 | >>>> | |
423 | my($x, @a); | |
0bb5f065 | 424 | $x = 1 foreach (@a); |
241416b8 | 425 | #### |
507a68aa | 426 | # 2 arguments in a 3 argument for |
241416b8 DM |
427 | for (my $i = 0; $i < 2;) { |
428 | my $z = 1; | |
429 | } | |
430 | #### | |
507a68aa | 431 | # 3 argument for |
241416b8 DM |
432 | for (my $i = 0; $i < 2; ++$i) { |
433 | my $z = 1; | |
434 | } | |
435 | #### | |
507a68aa | 436 | # 3 argument for again |
241416b8 DM |
437 | for (my $i = 0; $i < 2; ++$i) { |
438 | my $z = 1; | |
439 | } | |
440 | #### | |
22584011 FC |
441 | # 3-argument for with inverted condition |
442 | for (my $i; not $i;) { | |
443 | die; | |
444 | } | |
445 | for (my $i; not $i; ++$i) { | |
446 | die; | |
447 | } | |
88a758b5 FC |
448 | for (my $a; not +($1 || 2) ** 2;) { |
449 | die; | |
450 | } | |
22584011 FC |
451 | Something_to_put_the_loop_in_void_context(); |
452 | #### | |
507a68aa | 453 | # while/continue |
241416b8 DM |
454 | my $i; |
455 | while ($i) { my $z = 1; } continue { $i = 99; } | |
456 | #### | |
507a68aa | 457 | # foreach with my |
09d856fb | 458 | foreach my $i (1, 2) { |
241416b8 DM |
459 | my $z = 1; |
460 | } | |
461 | #### | |
4da9a2ca FC |
462 | # OPTIONS -p |
463 | # foreach with my under -p | |
464 | foreach my $i (1) { | |
465 | die; | |
466 | } | |
467 | #### | |
507a68aa | 468 | # foreach |
241416b8 DM |
469 | my $i; |
470 | foreach $i (1, 2) { | |
471 | my $z = 1; | |
472 | } | |
473 | #### | |
507a68aa | 474 | # foreach, 2 mys |
241416b8 DM |
475 | my $i; |
476 | foreach my $i (1, 2) { | |
477 | my $z = 1; | |
478 | } | |
479 | #### | |
507a68aa | 480 | # foreach with our |
241416b8 DM |
481 | foreach our $i (1, 2) { |
482 | my $z = 1; | |
483 | } | |
484 | #### | |
507a68aa | 485 | # foreach with my and our |
241416b8 DM |
486 | my $i; |
487 | foreach our $i (1, 2) { | |
488 | my $z = 1; | |
489 | } | |
3ac6e0f9 | 490 | #### |
bcff4148 FC |
491 | # foreach with state |
492 | # CONTEXT use feature "state"; | |
493 | foreach state $i (1, 2) { | |
494 | state $z = 1; | |
495 | } | |
496 | #### | |
507a68aa | 497 | # reverse sort |
3ac6e0f9 RGS |
498 | my @x; |
499 | print reverse sort(@x); | |
500 | #### | |
507a68aa | 501 | # sort with cmp |
3ac6e0f9 RGS |
502 | my @x; |
503 | print((sort {$b cmp $a} @x)); | |
504 | #### | |
507a68aa | 505 | # reverse sort with block |
3ac6e0f9 RGS |
506 | my @x; |
507 | print((reverse sort {$b <=> $a} @x)); | |
36d57d93 | 508 | #### |
507a68aa | 509 | # foreach reverse |
36d57d93 RGS |
510 | our @a; |
511 | print $_ foreach (reverse @a); | |
aae53c41 | 512 | #### |
507a68aa | 513 | # foreach reverse (not inplace) |
aae53c41 RGS |
514 | our @a; |
515 | print $_ foreach (reverse 1, 2..5); | |
f86ea535 | 516 | #### |
507a68aa | 517 | # bug #38684 |
f86ea535 SM |
518 | our @ary; |
519 | @ary = split(' ', 'foo', 0); | |
31c6271a | 520 | #### |
de183bbb FC |
521 | # Split to our array |
522 | our @array = split(//, 'foo', 0); | |
523 | #### | |
507a68aa | 524 | # bug #40055 |
31c6271a RD |
525 | do { () }; |
526 | #### | |
507a68aa | 527 | # bug #40055 |
31c6271a | 528 | do { my $x = 1; $x }; |
d9002312 | 529 | #### |
507a68aa | 530 | # <20061012113037.GJ25805@c4.convolution.nl> |
d9002312 SM |
531 | my $f = sub { |
532 | +{[]}; | |
533 | } ; | |
8b2d6640 | 534 | #### |
507a68aa | 535 | # bug #43010 |
8b2d6640 FC |
536 | '!@$%'->(); |
537 | #### | |
507a68aa | 538 | # bug #43010 |
8b2d6640 FC |
539 | ::(); |
540 | #### | |
507a68aa | 541 | # bug #43010 |
8b2d6640 FC |
542 | '::::'->(); |
543 | #### | |
507a68aa | 544 | # bug #43010 |
8b2d6640 | 545 | &::::; |
09d856fb | 546 | #### |
1b38d782 FC |
547 | # [perl #77172] |
548 | package rt77172; | |
549 | sub foo {} foo & & & foo; | |
550 | >>>> | |
551 | package rt77172; | |
552 | foo(&{&} & foo()); | |
553 | #### | |
507a68aa | 554 | # variables as method names |
09d856fb CK |
555 | my $bar; |
556 | 'Foo'->$bar('orz'); | |
35a99a08 | 557 | 'Foo'->$bar('orz') = 'a stranger stranger than before'; |
09d856fb | 558 | #### |
507a68aa | 559 | # constants as method names |
09d856fb CK |
560 | 'Foo'->bar('orz'); |
561 | #### | |
507a68aa | 562 | # constants as method names without () |
09d856fb | 563 | 'Foo'->bar; |
0ced6c29 | 564 | #### |
28bfcb02 | 565 | # [perl #47359] "indirect" method call notation |
1bf8bbb0 FC |
566 | our @bar; |
567 | foo{@bar}+1,->foo; | |
568 | (foo{@bar}+1),foo(); | |
569 | foo{@bar}1 xor foo(); | |
570 | >>>> | |
571 | our @bar; | |
572 | (foo { @bar } 1)->foo; | |
573 | (foo { @bar } 1), foo(); | |
574 | foo { @bar } 1 xor foo(); | |
575 | #### | |
e9c69003 | 576 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" |
205fef88 | 577 | # CONTEXT use feature ':5.10'; |
507a68aa | 578 | # say |
7ddd1a01 NC |
579 | say 'foo'; |
580 | #### | |
8f57bb34 | 581 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" |
8f57bb34 NC |
582 | # CONTEXT use 5.10.0; |
583 | # say in the context of use 5.10.0 | |
584 | say 'foo'; | |
585 | #### | |
586 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" | |
8f57bb34 NC |
587 | # say with use 5.10.0 |
588 | use 5.10.0; | |
589 | say 'foo'; | |
590 | >>>> | |
591 | no feature; | |
592 | use feature ':5.10'; | |
593 | say 'foo'; | |
594 | #### | |
595 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" | |
596 | # say with use feature ':5.10'; | |
597 | use feature ':5.10'; | |
598 | say 'foo'; | |
599 | >>>> | |
600 | use feature 'say', 'state', 'switch'; | |
601 | say 'foo'; | |
602 | #### | |
603 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" | |
8f57bb34 NC |
604 | # CONTEXT use feature ':5.10'; |
605 | # say with use 5.10.0 in the context of use feature | |
606 | use 5.10.0; | |
607 | say 'foo'; | |
608 | >>>> | |
609 | no feature; | |
610 | use feature ':5.10'; | |
611 | say 'foo'; | |
612 | #### | |
613 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" | |
614 | # CONTEXT use 5.10.0; | |
615 | # say with use feature ':5.10' in the context of use 5.10.0 | |
616 | use feature ':5.10'; | |
617 | say 'foo'; | |
618 | >>>> | |
619 | say 'foo'; | |
620 | #### | |
621 | # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" | |
622 | # CONTEXT use feature ':5.15'; | |
623 | # __SUB__ | |
624 | __SUB__; | |
625 | #### | |
626 | # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" | |
8f57bb34 NC |
627 | # CONTEXT use 5.15.0; |
628 | # __SUB__ in the context of use 5.15.0 | |
629 | __SUB__; | |
630 | #### | |
631 | # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" | |
8f57bb34 NC |
632 | # __SUB__ with use 5.15.0 |
633 | use 5.15.0; | |
634 | __SUB__; | |
635 | >>>> | |
636 | no feature; | |
637 | use feature ':5.16'; | |
638 | __SUB__; | |
639 | #### | |
640 | # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" | |
641 | # __SUB__ with use feature ':5.15'; | |
642 | use feature ':5.15'; | |
643 | __SUB__; | |
644 | >>>> | |
645 | use feature 'current_sub', 'evalbytes', 'fc', 'say', 'state', 'switch', 'unicode_strings', 'unicode_eval'; | |
646 | __SUB__; | |
647 | #### | |
648 | # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" | |
8f57bb34 NC |
649 | # CONTEXT use feature ':5.15'; |
650 | # __SUB__ with use 5.15.0 in the context of use feature | |
651 | use 5.15.0; | |
652 | __SUB__; | |
653 | >>>> | |
654 | no feature; | |
655 | use feature ':5.16'; | |
656 | __SUB__; | |
657 | #### | |
658 | # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" | |
659 | # CONTEXT use 5.15.0; | |
660 | # __SUB__ with use feature ':5.15' in the context of use 5.15.0 | |
661 | use feature ':5.15'; | |
662 | __SUB__; | |
663 | >>>> | |
664 | __SUB__; | |
665 | #### | |
e9c69003 | 666 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
205fef88 | 667 | # CONTEXT use feature ':5.10'; |
507a68aa | 668 | # state vars |
0ced6c29 RGS |
669 | state $x = 42; |
670 | #### | |
e9c69003 | 671 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
205fef88 | 672 | # CONTEXT use feature ':5.10'; |
507a68aa | 673 | # state var assignment |
7ddd1a01 NC |
674 | { |
675 | my $y = (state $x = 42); | |
676 | } | |
677 | #### | |
e9c69003 | 678 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
205fef88 | 679 | # CONTEXT use feature ':5.10'; |
c4a6f826 | 680 | # state vars in anonymous subroutines |
7ddd1a01 NC |
681 | $a = sub { |
682 | state $x; | |
683 | return $x++; | |
684 | } | |
685 | ; | |
644741fd NC |
686 | #### |
687 | # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' | |
507a68aa | 688 | # each @array; |
644741fd NC |
689 | each @ARGV; |
690 | each @$a; | |
691 | #### | |
692 | # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' | |
507a68aa | 693 | # keys @array; values @array |
644741fd NC |
694 | keys @$a if keys @ARGV; |
695 | values @ARGV if values @$a; | |
35925e80 | 696 | #### |
507a68aa | 697 | # Anonymous arrays and hashes, and references to them |
35925e80 RGS |
698 | my $a = {}; |
699 | my $b = \{}; | |
700 | my $c = []; | |
701 | my $d = \[]; | |
9210de83 FR |
702 | #### |
703 | # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version" | |
0f539b13 | 704 | # CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch'; |
507a68aa | 705 | # implicit smartmatch in given/when |
9210de83 FR |
706 | given ('foo') { |
707 | when ('bar') { continue; } | |
708 | when ($_ ~~ 'quux') { continue; } | |
709 | default { 0; } | |
710 | } | |
7ecdd211 | 711 | #### |
507a68aa | 712 | # conditions in elsifs (regression in change #33710 which fixed bug #37302) |
7ecdd211 PJ |
713 | if ($a) { x(); } |
714 | elsif ($b) { x(); } | |
715 | elsif ($a and $b) { x(); } | |
716 | elsif ($a or $b) { x(); } | |
717 | else { x(); } | |
03b22f1b | 718 | #### |
507a68aa | 719 | # interpolation in regexps |
03b22f1b RGS |
720 | my($y, $t); |
721 | /x${y}z$t/; | |
227375e1 | 722 | #### |
4a4b8592 | 723 | # TODO new undocumented cpan-bug #33708 |
507a68aa | 724 | # cpan-bug #33708 |
227375e1 RU |
725 | %{$_ || {}} |
726 | #### | |
4a4b8592 | 727 | # TODO hash constants not yet fixed |
507a68aa | 728 | # cpan-bug #33708 |
227375e1 RU |
729 | use constant H => { "#" => 1 }; H->{"#"} |
730 | #### | |
4a4b8592 | 731 | # TODO optimized away 0 not yet fixed |
507a68aa | 732 | # cpan-bug #33708 |
227375e1 | 733 | foreach my $i (@_) { 0 } |
edbe35ea | 734 | #### |
507a68aa | 735 | # tests with not, not optimized |
07f3cdf5 | 736 | my $c; |
edbe35ea VP |
737 | x() unless $a; |
738 | x() if not $a and $b; | |
739 | x() if $a and not $b; | |
740 | x() unless not $a and $b; | |
741 | x() unless $a and not $b; | |
742 | x() if not $a or $b; | |
743 | x() if $a or not $b; | |
744 | x() unless not $a or $b; | |
745 | x() unless $a or not $b; | |
07f3cdf5 VP |
746 | x() if $a and not $b and $c; |
747 | x() if not $a and $b and not $c; | |
748 | x() unless $a and not $b and $c; | |
749 | x() unless not $a and $b and not $c; | |
750 | x() if $a or not $b or $c; | |
751 | x() if not $a or $b or not $c; | |
752 | x() unless $a or not $b or $c; | |
753 | x() unless not $a or $b or not $c; | |
edbe35ea | 754 | #### |
507a68aa | 755 | # tests with not, optimized |
07f3cdf5 | 756 | my $c; |
edbe35ea VP |
757 | x() if not $a; |
758 | x() unless not $a; | |
759 | x() if not $a and not $b; | |
760 | x() unless not $a and not $b; | |
761 | x() if not $a or not $b; | |
762 | x() unless not $a or not $b; | |
07f3cdf5 VP |
763 | x() if not $a and not $b and $c; |
764 | x() unless not $a and not $b and $c; | |
765 | x() if not $a or not $b or $c; | |
766 | x() unless not $a or not $b or $c; | |
767 | x() if not $a and not $b and not $c; | |
768 | x() unless not $a and not $b and not $c; | |
769 | x() if not $a or not $b or not $c; | |
770 | x() unless not $a or not $b or not $c; | |
771 | x() unless not $a or not $b or not $c; | |
edbe35ea | 772 | >>>> |
07f3cdf5 | 773 | my $c; |
edbe35ea VP |
774 | x() unless $a; |
775 | x() if $a; | |
776 | x() unless $a or $b; | |
777 | x() if $a or $b; | |
778 | x() unless $a and $b; | |
07f3cdf5 VP |
779 | x() if $a and $b; |
780 | x() if not $a || $b and $c; | |
781 | x() unless not $a || $b and $c; | |
782 | x() if not $a && $b or $c; | |
783 | x() unless not $a && $b or $c; | |
784 | x() unless $a or $b or $c; | |
785 | x() if $a or $b or $c; | |
786 | x() unless $a and $b and $c; | |
787 | x() if $a and $b and $c; | |
788 | x() unless not $a && $b && $c; | |
71c4dbc3 | 789 | #### |
507a68aa | 790 | # tests that should be constant folded |
71c4dbc3 VP |
791 | x() if 1; |
792 | x() if GLIPP; | |
793 | x() if !GLIPP; | |
794 | x() if GLIPP && GLIPP; | |
795 | x() if !GLIPP || GLIPP; | |
796 | x() if do { GLIPP }; | |
797 | x() if do { no warnings 'void'; 5; GLIPP }; | |
798 | x() if do { !GLIPP }; | |
799 | if (GLIPP) { x() } else { z() } | |
800 | if (!GLIPP) { x() } else { z() } | |
801 | if (GLIPP) { x() } elsif (GLIPP) { z() } | |
802 | if (!GLIPP) { x() } elsif (GLIPP) { z() } | |
803 | if (GLIPP) { x() } elsif (!GLIPP) { z() } | |
804 | if (!GLIPP) { x() } elsif (!GLIPP) { z() } | |
805 | if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() } | |
806 | if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() } | |
807 | if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() } | |
808 | >>>> | |
809 | x(); | |
810 | x(); | |
811 | '???'; | |
812 | x(); | |
813 | x(); | |
814 | x(); | |
815 | x(); | |
816 | do { | |
817 | '???' | |
818 | }; | |
819 | do { | |
820 | x() | |
821 | }; | |
822 | do { | |
823 | z() | |
824 | }; | |
825 | do { | |
826 | x() | |
827 | }; | |
828 | do { | |
829 | z() | |
830 | }; | |
831 | do { | |
832 | x() | |
833 | }; | |
834 | '???'; | |
835 | do { | |
836 | t() | |
837 | }; | |
838 | '???'; | |
839 | !1; | |
840 | #### | |
719c50dc RGS |
841 | # TODO constant deparsing has been backed out for 5.12 |
842 | # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads" | |
507a68aa | 843 | # tests that shouldn't be constant folded |
ac0f1413 NC |
844 | # It might be fundamentally impossible to make this work on ithreads, in which |
845 | # case the TODO should become a SKIP | |
71c4dbc3 VP |
846 | x() if $a; |
847 | if ($a == 1) { x() } elsif ($b == 2) { z() } | |
848 | if (do { foo(); GLIPP }) { x() } | |
849 | if (do { $a++; GLIPP }) { x() } | |
850 | >>>> | |
851 | x() if $a; | |
852 | if ($a == 1) { x(); } elsif ($b == 2) { z(); } | |
2990415a FR |
853 | if (do { foo(); GLIPP }) { x(); } |
854 | if (do { ++$a; GLIPP }) { x(); } | |
855 | #### | |
0fa4a265 | 856 | # TODO constant deparsing has been backed out for 5.12 |
507a68aa | 857 | # tests for deparsing constants |
2990415a FR |
858 | warn PI; |
859 | #### | |
0fa4a265 | 860 | # TODO constant deparsing has been backed out for 5.12 |
507a68aa | 861 | # tests for deparsing imported constants |
3779476a | 862 | warn O_TRUNC; |
2990415a | 863 | #### |
0fa4a265 | 864 | # TODO constant deparsing has been backed out for 5.12 |
507a68aa | 865 | # tests for deparsing re-exported constants |
2990415a FR |
866 | warn O_CREAT; |
867 | #### | |
0fa4a265 | 868 | # TODO constant deparsing has been backed out for 5.12 |
507a68aa | 869 | # tests for deparsing imported constants that got deleted from the original namespace |
aaf9c2b2 | 870 | warn O_APPEND; |
2990415a | 871 | #### |
0fa4a265 DM |
872 | # TODO constant deparsing has been backed out for 5.12 |
873 | # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads" | |
507a68aa | 874 | # tests for deparsing constants which got turned into full typeglobs |
ac0f1413 NC |
875 | # It might be fundamentally impossible to make this work on ithreads, in which |
876 | # case the TODO should become a SKIP | |
2990415a FR |
877 | warn O_EXCL; |
878 | eval '@Fcntl::O_EXCL = qw/affe tiger/;'; | |
879 | warn O_EXCL; | |
880 | #### | |
0fa4a265 | 881 | # TODO constant deparsing has been backed out for 5.12 |
507a68aa | 882 | # tests for deparsing of blessed constant with overloaded numification |
2990415a | 883 | warn OVERLOADED_NUMIFICATION; |
79289e05 | 884 | #### |
507a68aa | 885 | # strict |
79289e05 | 886 | no strict; |
415d4c68 FC |
887 | print $x; |
888 | use strict 'vars'; | |
889 | print $main::x; | |
890 | use strict 'subs'; | |
891 | print $main::x; | |
892 | use strict 'refs'; | |
893 | print $main::x; | |
894 | no strict 'vars'; | |
79289e05 NC |
895 | $x; |
896 | #### | |
897 | # TODO Subsets of warnings could be encoded textually, rather than as bitflips. | |
507a68aa | 898 | # subsets of warnings |
79289e05 NC |
899 | no warnings 'deprecated'; |
900 | my $x; | |
901 | #### | |
902 | # TODO Better test for CPAN #33708 - the deparsed code has different behaviour | |
507a68aa | 903 | # CPAN #33708 |
79289e05 NC |
904 | use strict; |
905 | no warnings; | |
906 | ||
907 | foreach (0..3) { | |
908 | my $x = 2; | |
909 | { | |
910 | my $x if 0; | |
911 | print ++$x, "\n"; | |
912 | } | |
913 | } | |
d83f38d8 | 914 | #### |
507a68aa | 915 | # no attribute list |
d83f38d8 NC |
916 | my $pi = 4; |
917 | #### | |
2dc78664 NC |
918 | # SKIP ?$] > 5.013006 && ":= is now a syntax error" |
919 | # := treated as an empty attribute list | |
d83f38d8 NC |
920 | no warnings; |
921 | my $pi := 4; | |
922 | >>>> | |
923 | no warnings; | |
924 | my $pi = 4; | |
925 | #### | |
507a68aa | 926 | # : = empty attribute list |
d83f38d8 NC |
927 | my $pi : = 4; |
928 | >>>> | |
929 | my $pi = 4; | |
689e417f | 930 | #### |
507a68aa | 931 | # in place sort |
689e417f VP |
932 | our @a; |
933 | my @b; | |
934 | @a = sort @a; | |
935 | @b = sort @b; | |
936 | (); | |
937 | #### | |
507a68aa | 938 | # in place reverse |
689e417f VP |
939 | our @a; |
940 | my @b; | |
941 | @a = reverse @a; | |
942 | @b = reverse @b; | |
943 | (); | |
06fc6867 | 944 | #### |
507a68aa | 945 | # #71870 Use of uninitialized value in bitwise and B::Deparse |
06fc6867 VP |
946 | my($r, $s, @a); |
947 | @a = split(/foo/, $s, 0); | |
948 | $r = qr/foo/; | |
949 | @a = split(/$r/, $s, 0); | |
950 | (); | |
98a1a137 | 951 | #### |
507a68aa | 952 | # package declaration before label |
98a1a137 Z |
953 | { |
954 | package Foo; | |
955 | label: print 123; | |
956 | } | |
538f5756 | 957 | #### |
507a68aa | 958 | # shift optimisation |
538f5756 RZ |
959 | shift; |
960 | >>>> | |
961 | shift(); | |
962 | #### | |
507a68aa | 963 | # shift optimisation |
538f5756 RZ |
964 | shift @_; |
965 | #### | |
507a68aa | 966 | # shift optimisation |
538f5756 RZ |
967 | pop; |
968 | >>>> | |
969 | pop(); | |
970 | #### | |
507a68aa | 971 | # shift optimisation |
538f5756 | 972 | pop @_; |
a539498a | 973 | #### |
507a68aa | 974 | #[perl #20444] |
a539498a FC |
975 | "foo" =~ (1 ? /foo/ : /bar/); |
976 | "foo" =~ (1 ? y/foo// : /bar/); | |
5e5a1632 | 977 | "foo" =~ (1 ? y/foo//r : /bar/); |
a539498a FC |
978 | "foo" =~ (1 ? s/foo// : /bar/); |
979 | >>>> | |
980 | 'foo' =~ ($_ =~ /foo/); | |
981 | 'foo' =~ ($_ =~ tr/fo//); | |
5e5a1632 | 982 | 'foo' =~ ($_ =~ tr/fo//r); |
a539498a | 983 | 'foo' =~ ($_ =~ s/foo//); |
e0ab66ad | 984 | #### |
5e5a1632 FC |
985 | # The fix for [perl #20444] broke this. |
986 | 'foo' =~ do { () }; | |
987 | #### | |
4b58603b FC |
988 | # [perl #81424] match against aelemfast_lex |
989 | my @s; | |
990 | print /$s[1]/; | |
991 | #### | |
36727b53 FC |
992 | # /$#a/ |
993 | print /$#main::a/; | |
994 | #### | |
b9bc576f | 995 | # [perl #91318] /regexp/applaud |
09622ee2 FC |
996 | print /a/a, s/b/c/a; |
997 | print /a/aa, s/b/c/aa; | |
998 | print /a/p, s/b/c/p; | |
999 | print /a/l, s/b/c/l; | |
1000 | print /a/u, s/b/c/u; | |
b9bc576f FC |
1001 | { |
1002 | use feature "unicode_strings"; | |
09622ee2 | 1003 | print /a/d, s/b/c/d; |
b9bc576f FC |
1004 | } |
1005 | { | |
1006 | use re "/u"; | |
09622ee2 | 1007 | print /a/d, s/b/c/d; |
b9bc576f | 1008 | } |
dff5ffe4 FC |
1009 | { |
1010 | use 5.012; | |
1011 | print /a/d, s/b/c/d; | |
1012 | } | |
b9bc576f | 1013 | >>>> |
09622ee2 FC |
1014 | print /a/a, s/b/c/a; |
1015 | print /a/aa, s/b/c/aa; | |
1016 | print /a/p, s/b/c/p; | |
1017 | print /a/l, s/b/c/l; | |
1018 | print /a/u, s/b/c/u; | |
b9bc576f | 1019 | { |
a8095af7 | 1020 | use feature 'unicode_strings'; |
09622ee2 | 1021 | print /a/d, s/b/c/d; |
b9bc576f FC |
1022 | } |
1023 | { | |
0bb01b05 FC |
1024 | BEGIN { $^H{'reflags'} = '0'; |
1025 | $^H{'reflags_charset'} = '2'; } | |
09622ee2 | 1026 | print /a/d, s/b/c/d; |
b9bc576f | 1027 | } |
dff5ffe4 FC |
1028 | { |
1029 | no feature; | |
1030 | use feature ':5.12'; | |
1031 | print /a/d, s/b/c/d; | |
1032 | } | |
b9bc576f | 1033 | #### |
9f125c4a FC |
1034 | # [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns) |
1035 | s/foo/\(3);/eg; | |
1036 | #### | |
e7afc405 FC |
1037 | # y///r |
1038 | tr/a/b/r; | |
cb8157e3 | 1039 | #### |
cb8578ff | 1040 | # [perl #90898] |
f4002a4b | 1041 | <a,>; |
09dcfa7d FC |
1042 | #### |
1043 | # [perl #91008] | |
d401967c | 1044 | # CONTEXT no warnings 'experimental::autoderef'; |
09dcfa7d FC |
1045 | each $@; |
1046 | keys $~; | |
1047 | values $!; | |
5d8c42c2 FC |
1048 | #### |
1049 | # readpipe with complex expression | |
1050 | readpipe $a + $b; | |
93bad3fd NC |
1051 | #### |
1052 | # aelemfast | |
1053 | $b::a[0] = 1; | |
1054 | #### | |
1055 | # aelemfast for a lexical | |
1056 | my @a; | |
1057 | $a[0] = 1; | |
80e3f4ad FC |
1058 | #### |
1059 | # feature features without feature | |
0f539b13 | 1060 | # CONTEXT no warnings 'experimental::smartmatch'; |
80e3f4ad | 1061 | CORE::state $x; |
223b1722 FC |
1062 | CORE::say $x; |
1063 | CORE::given ($x) { | |
1064 | CORE::when (3) { | |
1065 | continue; | |
1066 | } | |
1067 | CORE::default { | |
1068 | CORE::break; | |
1069 | } | |
1070 | } | |
1071 | CORE::evalbytes ''; | |
1072 | () = CORE::__SUB__; | |
838f2281 | 1073 | () = CORE::fc $x; |
223b1722 FC |
1074 | #### |
1075 | # feature features when feature has been disabled by use VERSION | |
0f539b13 | 1076 | # CONTEXT no warnings 'experimental::smartmatch'; |
223b1722 FC |
1077 | use feature (sprintf(":%vd", $^V)); |
1078 | use 1; | |
1079 | CORE::state $x; | |
1080 | CORE::say $x; | |
1081 | CORE::given ($x) { | |
1082 | CORE::when (3) { | |
1083 | continue; | |
1084 | } | |
1085 | CORE::default { | |
1086 | CORE::break; | |
1087 | } | |
1088 | } | |
1089 | CORE::evalbytes ''; | |
1090 | () = CORE::__SUB__; | |
1091 | >>>> | |
205fef88 NC |
1092 | CORE::state $x; |
1093 | CORE::say $x; | |
1094 | CORE::given ($x) { | |
1095 | CORE::when (3) { | |
1096 | continue; | |
1097 | } | |
1098 | CORE::default { | |
1099 | CORE::break; | |
1100 | } | |
1101 | } | |
1102 | CORE::evalbytes ''; | |
1103 | () = CORE::__SUB__; | |
1104 | #### | |
1105 | # (the above test with CONTEXT, and the output is equivalent but different) | |
0f539b13 | 1106 | # CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch'; |
205fef88 NC |
1107 | # feature features when feature has been disabled by use VERSION |
1108 | use feature (sprintf(":%vd", $^V)); | |
1109 | use 1; | |
1110 | CORE::state $x; | |
1111 | CORE::say $x; | |
1112 | CORE::given ($x) { | |
1113 | CORE::when (3) { | |
1114 | continue; | |
1115 | } | |
1116 | CORE::default { | |
1117 | CORE::break; | |
1118 | } | |
1119 | } | |
1120 | CORE::evalbytes ''; | |
1121 | () = CORE::__SUB__; | |
1122 | >>>> | |
0bb01b05 FC |
1123 | no feature; |
1124 | use feature ':default'; | |
223b1722 | 1125 | CORE::state $x; |
80e3f4ad FC |
1126 | CORE::say $x; |
1127 | CORE::given ($x) { | |
1128 | CORE::when (3) { | |
1129 | continue; | |
1130 | } | |
1131 | CORE::default { | |
e36901c8 | 1132 | CORE::break; |
80e3f4ad FC |
1133 | } |
1134 | } | |
7d789282 | 1135 | CORE::evalbytes ''; |
84ed0108 | 1136 | () = CORE::__SUB__; |
6ec73527 | 1137 | #### |
7741ceed FC |
1138 | # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" |
1139 | # lexical subroutines and keywords of the same name | |
1140 | # CONTEXT use feature 'lexical_subs', 'switch'; no warnings 'experimental'; | |
1141 | my sub default; | |
1142 | my sub else; | |
1143 | my sub elsif; | |
1144 | my sub for; | |
1145 | my sub foreach; | |
1146 | my sub given; | |
1147 | my sub if; | |
1148 | my sub m; | |
1149 | my sub no; | |
1150 | my sub package; | |
1151 | my sub q; | |
1152 | my sub qq; | |
1153 | my sub qr; | |
1154 | my sub qx; | |
1155 | my sub require; | |
1156 | my sub s; | |
1157 | my sub sub; | |
1158 | my sub tr; | |
1159 | my sub unless; | |
1160 | my sub until; | |
1161 | my sub use; | |
1162 | my sub when; | |
1163 | my sub while; | |
1164 | CORE::default { die; } | |
1165 | CORE::if ($1) { die; } | |
1166 | CORE::if ($1) { die; } | |
1167 | CORE::elsif ($1) { die; } | |
1168 | CORE::else { die; } | |
1169 | CORE::for (die; $1; die) { die; } | |
1170 | CORE::foreach $_ (1 .. 10) { die; } | |
1171 | die CORE::foreach (1); | |
1172 | CORE::given ($1) { die; } | |
1173 | CORE::m[/]; | |
1174 | CORE::m?/?; | |
1175 | CORE::package foo; | |
1176 | CORE::no strict; | |
1177 | () = (CORE::q['], CORE::qq["$_], CORE::qr//, CORE::qx[`]); | |
1178 | CORE::require 1; | |
1179 | CORE::s///; | |
1180 | () = CORE::sub { die; } ; | |
1181 | CORE::tr///; | |
1182 | CORE::unless ($1) { die; } | |
1183 | CORE::until ($1) { die; } | |
1184 | die CORE::until $1; | |
1185 | CORE::use strict; | |
1186 | CORE::when ($1 ~~ $2) { die; } | |
1187 | CORE::while ($1) { die; } | |
1188 | die CORE::while $1; | |
1189 | #### | |
0bb01b05 FC |
1190 | # Feature hints |
1191 | use feature 'current_sub', 'evalbytes'; | |
1192 | print; | |
1193 | use 1; | |
1194 | print; | |
1195 | use 5.014; | |
1196 | print; | |
1197 | no feature 'unicode_strings'; | |
1198 | print; | |
1199 | >>>> | |
a8095af7 | 1200 | use feature 'current_sub', 'evalbytes'; |
0bb01b05 FC |
1201 | print $_; |
1202 | no feature; | |
1203 | use feature ':default'; | |
1204 | print $_; | |
1205 | no feature; | |
1206 | use feature ':5.12'; | |
1207 | print $_; | |
a8095af7 | 1208 | no feature 'unicode_strings'; |
0bb01b05 FC |
1209 | print $_; |
1210 | #### | |
6ec73527 FC |
1211 | # $#- $#+ $#{%} etc. |
1212 | my @x; | |
5b6da579 | 1213 | @x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*}); |
6ec73527 FC |
1214 | @x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,}); |
1215 | @x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-); | |
1216 | @x = ($#{;}, $#{:}); | |
61154ac0 | 1217 | #### |
ff683671 NC |
1218 | # ${#} interpolated |
1219 | # It's a known TODO that warnings are deparsed as bits, not textually. | |
1220 | no warnings; | |
61154ac0 | 1221 | () = "${#}a"; |
958ed56b | 1222 | #### |
337d7381 FC |
1223 | # [perl #86060] $( $| $) in regexps need braces |
1224 | /${(}/; | |
1225 | /${|}/; | |
1226 | /${)}/; | |
1227 | /${(}${|}${)}/; | |
1228 | #### | |
958ed56b FC |
1229 | # ()[...] |
1230 | my(@a) = ()[()]; | |
521795fe FC |
1231 | #### |
1232 | # sort(foo(bar)) | |
1233 | # sort(foo(bar)) is interpreted as sort &foo(bar) | |
1234 | # sort foo(bar) is interpreted as sort foo bar | |
1235 | # parentheses are not optional in this case | |
1236 | print sort(foo('bar')); | |
1237 | >>>> | |
1238 | print sort(foo('bar')); | |
24fcb59f FC |
1239 | #### |
1240 | # substr assignment | |
1241 | substr(my $a, 0, 0) = (foo(), bar()); | |
1242 | $a++; | |
04be0204 | 1243 | #### |
d1718a7c FC |
1244 | # This following line works around an unfixed bug that we are not trying to |
1245 | # test for here: | |
1246 | # CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised | |
04be0204 FC |
1247 | # hint hash |
1248 | BEGIN { $^H{'foo'} = undef; } | |
1249 | { | |
1250 | BEGIN { $^H{'bar'} = undef; } | |
1251 | { | |
1252 | BEGIN { $^H{'baz'} = undef; } | |
1253 | { | |
1254 | print $_; | |
1255 | } | |
1256 | print $_; | |
1257 | } | |
1258 | print $_; | |
1259 | } | |
035146a3 FC |
1260 | BEGIN { $^H{q[']} = '('; } |
1261 | print $_; | |
c306e834 | 1262 | #### |
d1718a7c FC |
1263 | # This following line works around an unfixed bug that we are not trying to |
1264 | # test for here: | |
1265 | # CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised | |
c306e834 FC |
1266 | # hint hash changes that serialise the same way with sort %hh |
1267 | BEGIN { $^H{'a'} = 'b'; } | |
1268 | { | |
1269 | BEGIN { $^H{'b'} = 'a'; delete $^H{'a'}; } | |
1270 | print $_; | |
1271 | } | |
1272 | print $_; | |
94bb57f9 FC |
1273 | #### |
1274 | # [perl #47361] do({}) and do +{} (variants of do-file) | |
1275 | do({}); | |
1276 | do +{}; | |
8b46c09b FC |
1277 | sub foo::do {} |
1278 | package foo; | |
1279 | CORE::do({}); | |
1280 | CORE::do +{}; | |
94bb57f9 FC |
1281 | >>>> |
1282 | do({}); | |
1283 | do({}); | |
8b46c09b FC |
1284 | package foo; |
1285 | CORE::do({}); | |
1286 | CORE::do({}); | |
9c56d9ea FC |
1287 | #### |
1288 | # [perl #77096] functions that do not follow the llafr | |
1289 | () = (return 1) + time; | |
1290 | () = (return ($1 + $2) * $3) + time; | |
1291 | () = (return ($a xor $b)) + time; | |
1292 | () = (do 'file') + time; | |
1293 | () = (do ($1 + $2) * $3) + time; | |
1294 | () = (do ($1 xor $2)) + time; | |
41df74e3 FC |
1295 | () = (goto 1) + 3; |
1296 | () = (require 'foo') + 3; | |
1297 | () = (require foo) + 3; | |
266da325 | 1298 | () = (CORE::dump 1) + 3; |
41df74e3 FC |
1299 | () = (last 1) + 3; |
1300 | () = (next 1) + 3; | |
1301 | () = (redo 1) + 3; | |
5830412d FC |
1302 | () = (-R $_) + 3; |
1303 | () = (-W $_) + 3; | |
1304 | () = (-X $_) + 3; | |
1305 | () = (-r $_) + 3; | |
1306 | () = (-w $_) + 3; | |
1307 | () = (-x $_) + 3; | |
2462c3cc | 1308 | #### |
1cabb3b3 FC |
1309 | # [perl #97476] not() *does* follow the llafr |
1310 | $_ = ($a xor not +($1 || 2) ** 2); | |
1311 | #### | |
4d8ac5c7 FC |
1312 | # Precedence conundrums with argument-less function calls |
1313 | () = (eof) + 1; | |
1314 | () = (return) + 1; | |
1315 | () = (return, 1); | |
7bc8c979 FC |
1316 | () = warn; |
1317 | () = warn() + 1; | |
4d8ac5c7 FC |
1318 | () = setpgrp() + 1; |
1319 | #### | |
1eb0b7be FC |
1320 | # loopexes have assignment prec |
1321 | () = (CORE::dump a) | 'b'; | |
1322 | () = (goto a) | 'b'; | |
1323 | () = (last a) | 'b'; | |
1324 | () = (next a) | 'b'; | |
1325 | () = (redo a) | 'b'; | |
1326 | #### | |
2462c3cc FC |
1327 | # [perl #63558] open local(*FH) |
1328 | open local *FH; | |
564cd6cb | 1329 | pipe local *FH, local *FH; |
843b15cc | 1330 | #### |
b89b7257 FC |
1331 | # [perl #91416] open "string" |
1332 | open 'open'; | |
1333 | open '####'; | |
1334 | open '^A'; | |
1335 | open "\ca"; | |
1336 | >>>> | |
1337 | open *open; | |
1338 | open '####'; | |
1339 | open '^A'; | |
1340 | open *^A; | |
1341 | #### | |
be6cf5cf FC |
1342 | # "string"->[] ->{} |
1343 | no strict 'vars'; | |
1344 | () = 'open'->[0]; #aelemfast | |
1345 | () = '####'->[0]; | |
1346 | () = '^A'->[0]; | |
1347 | () = "\ca"->[0]; | |
b861b87f | 1348 | () = 'a::]b'->[0]; |
10e8e32b FC |
1349 | () = 'open'->[$_]; #aelem |
1350 | () = '####'->[$_]; | |
1351 | () = '^A'->[$_]; | |
1352 | () = "\ca"->[$_]; | |
b861b87f | 1353 | () = 'a::]b'->[$_]; |
10e8e32b FC |
1354 | () = 'open'->{0}; #helem |
1355 | () = '####'->{0}; | |
1356 | () = '^A'->{0}; | |
1357 | () = "\ca"->{0}; | |
b861b87f | 1358 | () = 'a::]b'->{0}; |
be6cf5cf | 1359 | >>>> |
415d4c68 | 1360 | no strict 'vars'; |
be6cf5cf FC |
1361 | () = $open[0]; |
1362 | () = '####'->[0]; | |
1363 | () = '^A'->[0]; | |
1364 | () = $^A[0]; | |
b861b87f | 1365 | () = 'a::]b'->[0]; |
10e8e32b FC |
1366 | () = $open[$_]; |
1367 | () = '####'->[$_]; | |
1368 | () = '^A'->[$_]; | |
1369 | () = $^A[$_]; | |
b861b87f | 1370 | () = 'a::]b'->[$_]; |
10e8e32b FC |
1371 | () = $open{'0'}; |
1372 | () = '####'->{'0'}; | |
1373 | () = '^A'->{'0'}; | |
1374 | () = $^A{'0'}; | |
b861b87f | 1375 | () = 'a::]b'->{'0'}; |
be6cf5cf | 1376 | #### |
843b15cc FC |
1377 | # [perl #74740] -(f()) vs -f() |
1378 | $_ = -(f()); | |
c75b4828 FC |
1379 | #### |
1380 | # require <binop> | |
1381 | require 'a' . $1; | |
afb60448 HY |
1382 | #### |
1383 | #[perl #30504] foreach-my postfix/prefix difference | |
1384 | $_ = 'foo' foreach my ($foo1, $bar1, $baz1); | |
1385 | foreach (my ($foo2, $bar2, $baz2)) { $_ = 'foo' } | |
1386 | foreach my $i (my ($foo3, $bar3, $baz3)) { $i = 'foo' } | |
1387 | >>>> | |
1388 | $_ = 'foo' foreach (my($foo1, $bar1, $baz1)); | |
1389 | foreach $_ (my($foo2, $bar2, $baz2)) { | |
1390 | $_ = 'foo'; | |
1391 | } | |
1392 | foreach my $i (my($foo3, $bar3, $baz3)) { | |
1393 | $i = 'foo'; | |
1394 | } | |
1395 | #### | |
1396 | #[perl #108224] foreach with continue block | |
1397 | foreach (1 .. 3) { print } continue { print "\n" } | |
1398 | foreach (1 .. 3) { } continue { } | |
1399 | foreach my $i (1 .. 3) { print $i } continue { print "\n" } | |
1400 | foreach my $i (1 .. 3) { } continue { } | |
1401 | >>>> | |
1402 | foreach $_ (1 .. 3) { | |
1403 | print $_; | |
1404 | } | |
1405 | continue { | |
1406 | print "\n"; | |
1407 | } | |
1408 | foreach $_ (1 .. 3) { | |
1409 | (); | |
1410 | } | |
1411 | continue { | |
1412 | (); | |
1413 | } | |
1414 | foreach my $i (1 .. 3) { | |
1415 | print $i; | |
1416 | } | |
1417 | continue { | |
1418 | print "\n"; | |
1419 | } | |
1420 | foreach my $i (1 .. 3) { | |
1421 | (); | |
1422 | } | |
1423 | continue { | |
1424 | (); | |
1425 | } | |
bc1cc2c3 DM |
1426 | #### |
1427 | # file handles | |
1428 | no strict; | |
1429 | my $mfh; | |
1430 | open F; | |
1431 | open *F; | |
1432 | open $fh; | |
1433 | open $mfh; | |
1434 | open 'a+b'; | |
1435 | select *F; | |
1436 | select F; | |
1437 | select $f; | |
1438 | select $mfh; | |
1439 | select 'a+b'; | |
a7fd8ef6 DM |
1440 | #### |
1441 | # 'my' works with padrange op | |
1442 | my($z, @z); | |
1443 | my $m1; | |
1444 | $m1 = 1; | |
1445 | $z = $m1; | |
1446 | my $m2 = 2; | |
1447 | my($m3, $m4); | |
1448 | ($m3, $m4) = (1, 2); | |
1449 | @z = ($m3, $m4); | |
1450 | my($m5, $m6) = (1, 2); | |
1451 | my($m7, undef, $m8) = (1, 2, 3); | |
1452 | @z = ($m7, undef, $m8); | |
1453 | ($m7, undef, $m8) = (1, 2, 3); | |
1454 | #### | |
1455 | # 'our/local' works with padrange op | |
1456 | no strict; | |
1457 | our($z, @z); | |
1458 | our $o1; | |
1459 | local $o11; | |
1460 | $o1 = 1; | |
1461 | local $o1 = 1; | |
1462 | $z = $o1; | |
1463 | $z = local $o1; | |
1464 | our $o2 = 2; | |
1465 | our($o3, $o4); | |
1466 | ($o3, $o4) = (1, 2); | |
1467 | local($o3, $o4) = (1, 2); | |
1468 | @z = ($o3, $o4); | |
1469 | @z = local($o3, $o4); | |
1470 | our($o5, $o6) = (1, 2); | |
1471 | our($o7, undef, $o8) = (1, 2, 3); | |
1472 | @z = ($o7, undef, $o8); | |
1473 | @z = local($o7, undef, $o8); | |
1474 | ($o7, undef, $o8) = (1, 2, 3); | |
1475 | local($o7, undef, $o8) = (1, 2, 3); | |
1476 | #### | |
1477 | # 'state' works with padrange op | |
1478 | no strict; | |
1479 | use feature 'state'; | |
1480 | state($z, @z); | |
1481 | state $s1; | |
1482 | $s1 = 1; | |
1483 | $z = $s1; | |
1484 | state $s2 = 2; | |
1485 | state($s3, $s4); | |
1486 | ($s3, $s4) = (1, 2); | |
1487 | @z = ($s3, $s4); | |
1488 | # assignment of state lists isn't implemented yet | |
1489 | #state($s5, $s6) = (1, 2); | |
1490 | #state($s7, undef, $s8) = (1, 2, 3); | |
1491 | #@z = ($s7, undef, $s8); | |
1492 | ($s7, undef, $s8) = (1, 2, 3); | |
1493 | #### | |
1494 | # anon lists with padrange | |
1495 | my($a, $b); | |
1496 | my $c = [$a, $b]; | |
1497 | my $d = {$a, $b}; | |
1498 | #### | |
1499 | # slices with padrange | |
1500 | my($a, $b); | |
1501 | my(@x, %y); | |
1502 | @x = @x[$a, $b]; | |
1503 | @x = @y{$a, $b}; | |
1504 | #### | |
1505 | # binops with padrange | |
1506 | my($a, $b, $c); | |
1507 | $c = $a cmp $b; | |
1508 | $c = $a + $b; | |
1509 | $a += $b; | |
1510 | $c = $a - $b; | |
1511 | $a -= $b; | |
1512 | $c = my $a1 cmp $b; | |
1513 | $c = my $a2 + $b; | |
1514 | $a += my $b1; | |
1515 | $c = my $a3 - $b; | |
1516 | $a -= my $b2; | |
1517 | #### | |
1518 | # 'x' with padrange | |
1519 | my($a, $b, $c, $d, @e); | |
1520 | $c = $a x $b; | |
1521 | $a x= $b; | |
1522 | @e = ($a) x $d; | |
1523 | @e = ($a, $b) x $d; | |
1524 | @e = ($a, $b, $c) x $d; | |
1525 | @e = ($a, 1) x $d; | |
d5524600 DM |
1526 | #### |
1527 | # @_ with padrange | |
1528 | my($a, $b, $c) = @_; | |
ce4062e7 AC |
1529 | #### |
1530 | # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" | |
1531 | # TODO unimplemented in B::Deparse; RT #116553 | |
1532 | # lexical subroutine | |
1533 | use feature 'lexical_subs'; | |
601448c3 | 1534 | no warnings "experimental::lexical_subs"; |
ce4062e7 AC |
1535 | my sub f {} |
1536 | print f(); | |
f0cf3754 AC |
1537 | #### |
1538 | # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" | |
1539 | # TODO unimplemented in B::Deparse; RT #116553 | |
1540 | # lexical "state" subroutine | |
1541 | use feature 'state', 'lexical_subs'; | |
1542 | no warnings 'experimental::lexical_subs'; | |
1543 | state sub f {} | |
1544 | print f(); | |
bcbe2b27 | 1545 | #### |
8443930e FC |
1546 | # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" |
1547 | # TODO unimplemented in B::Deparse; RT #116553 | |
1548 | # lexical subroutine scoping | |
1549 | # CONTEXT use feature 'lexical_subs'; no warnings 'experimental::lexical_subs'; | |
1550 | { | |
1551 | { | |
1552 | my sub a { die; } | |
1553 | { | |
1554 | foo(); | |
1555 | my sub b; | |
1556 | b(); | |
1557 | main::b(); | |
1558 | my $b; | |
1559 | sub b { $b } | |
1560 | } | |
1561 | } | |
1562 | b(); | |
1563 | } | |
1564 | #### | |
bcbe2b27 FC |
1565 | # Elements of %# should not be confused with $#{ array } |
1566 | () = ${#}{'foo'}; | |
c4cf781e FC |
1567 | #### |
1568 | # [perl #121050] Prototypes with whitespace | |
1569 | sub _121050(\$ \$) { } | |
1570 | _121050($a,$b); | |
1571 | sub _121050empty( ) {} | |
1572 | () = _121050empty() + 1; | |
1573 | >>>> | |
1574 | _121050 $a, $b; | |
1575 | () = _121050empty + 1; | |
b024352e DM |
1576 | #### |
1577 | # ensure aelemfast works in the range -128..127 and that there's no | |
1578 | # funky edge cases | |
1579 | my $x; | |
1580 | no strict 'vars'; | |
1581 | $x = $a[-256] + $a[-255] + $a[-129] + $a[-128] + $a[-127] + $a[-1] + $a[0]; | |
1582 | $x = $a[1] + $a[126] + $a[127] + $a[128] + $a[255] + $a[256]; | |
1583 | my @b; | |
1584 | $x = $b[-256] + $b[-255] + $b[-129] + $b[-128] + $b[-127] + $b[-1] + $b[0]; | |
1585 | $x = $b[1] + $b[126] + $b[127] + $b[128] + $b[255] + $b[256]; | |
e09d73a6 DIM |
1586 | #### |
1587 | # 'm' must be preserved in m?? | |
1588 | m??; | |
c8ec376c FC |
1589 | #### |
1590 | # \(@array) and \(..., (@array), ...) | |
1591 | my(@array, %hash, @a, @b, %c, %d); | |
1592 | () = \(@array); | |
1593 | () = \(%hash); | |
1594 | () = \(@a, (@b), (%c), %d); | |
1595 | () = \(@Foo::array); | |
1596 | () = \(%Foo::hash); | |
1597 | () = \(@Foo::a, (@Foo::b), (%Foo::c), %Foo::d); | |
a958cfbb FC |
1598 | #### |
1599 | # subs synonymous with keywords | |
1600 | main::our(); | |
1601 | main::pop(); | |
1602 | state(); | |
1603 | use feature 'state'; | |
1604 | main::state(); |