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 | |
fea7fb25 | 16 | my $tests = 20; # 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 | ||
fea7fb25 DM |
273 | # literal big chars under 'use utf8' |
274 | is($deparse->coderef2text(sub{ use utf8; /€/; }), | |
275 | '{ | |
276 | /\x{20ac}/; | |
277 | }', | |
278 | "qr/euro/"); | |
279 | ||
93a8ff62 | 280 | |
d8cf01c3 | 281 | done_testing($tests); |
507a68aa | 282 | |
ad46c0be | 283 | __DATA__ |
b8346d05 KW |
284 | # TODO [perl #120950] This succeeds when run a 2nd time |
285 | # y/uni/code/ | |
286 | tr/\x{345}/\x{370}/; | |
287 | #### | |
288 | # y/uni/code/ [perl #120950] This 2nd instance succeeds | |
289 | tr/\x{345}/\x{370}/; | |
290 | #### | |
507a68aa | 291 | # A constant |
ad46c0be RH |
292 | 1; |
293 | #### | |
507a68aa | 294 | # Constants in a block |
ad46c0be RH |
295 | { |
296 | no warnings; | |
297 | '???'; | |
298 | 2; | |
299 | } | |
300 | #### | |
507a68aa | 301 | # Lexical and simple arithmetic |
ad46c0be RH |
302 | my $test; |
303 | ++$test and $test /= 2; | |
304 | >>>> | |
305 | my $test; | |
306 | $test /= 2 if ++$test; | |
307 | #### | |
507a68aa | 308 | # list x |
ad46c0be RH |
309 | -((1, 2) x 2); |
310 | #### | |
507a68aa | 311 | # lvalue sub |
ad46c0be RH |
312 | { |
313 | my $test = sub : lvalue { | |
314 | my $x; | |
315 | } | |
316 | ; | |
317 | } | |
318 | #### | |
507a68aa | 319 | # method |
ad46c0be RH |
320 | { |
321 | my $test = sub : method { | |
322 | my $x; | |
323 | } | |
324 | ; | |
325 | } | |
326 | #### | |
507a68aa | 327 | # block with continue |
87a42246 | 328 | { |
ad46c0be | 329 | 234; |
f99a63a2 | 330 | } |
ad46c0be RH |
331 | continue { |
332 | 123; | |
87a42246 | 333 | } |
ce4e655d | 334 | #### |
507a68aa | 335 | # lexical and package scalars |
ce4e655d RH |
336 | my $x; |
337 | print $main::x; | |
338 | #### | |
507a68aa | 339 | # lexical and package arrays |
ce4e655d RH |
340 | my @x; |
341 | print $main::x[1]; | |
14a55f98 | 342 | #### |
507a68aa | 343 | # lexical and package hashes |
14a55f98 RH |
344 | my %x; |
345 | $x{warn()}; | |
ad8caead | 346 | #### |
507a68aa | 347 | # <> |
ad8caead RGS |
348 | my $foo; |
349 | $_ .= <ARGV> . <$foo>; | |
cef22867 | 350 | #### |
507a68aa | 351 | # \x{} |
11454c59 | 352 | my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ"; |
4ae52e81 | 353 | #### |
507a68aa | 354 | # s///e |
4ae52e81 | 355 | s/x/'y';/e; |
ef90d20a FC |
356 | s/x/$a;/e; |
357 | s/x/complex_expression();/e; | |
241416b8 | 358 | #### |
507a68aa | 359 | # block |
241416b8 DM |
360 | { my $x; } |
361 | #### | |
507a68aa | 362 | # while 1 |
241416b8 DM |
363 | while (1) { my $k; } |
364 | #### | |
507a68aa | 365 | # trailing for |
241416b8 DM |
366 | my ($x,@a); |
367 | $x=1 for @a; | |
368 | >>>> | |
369 | my($x, @a); | |
0bb5f065 | 370 | $x = 1 foreach (@a); |
241416b8 | 371 | #### |
507a68aa | 372 | # 2 arguments in a 3 argument for |
241416b8 DM |
373 | for (my $i = 0; $i < 2;) { |
374 | my $z = 1; | |
375 | } | |
376 | #### | |
507a68aa | 377 | # 3 argument for |
241416b8 DM |
378 | for (my $i = 0; $i < 2; ++$i) { |
379 | my $z = 1; | |
380 | } | |
381 | #### | |
507a68aa | 382 | # 3 argument for again |
241416b8 DM |
383 | for (my $i = 0; $i < 2; ++$i) { |
384 | my $z = 1; | |
385 | } | |
386 | #### | |
507a68aa | 387 | # while/continue |
241416b8 DM |
388 | my $i; |
389 | while ($i) { my $z = 1; } continue { $i = 99; } | |
390 | #### | |
507a68aa | 391 | # foreach with my |
09d856fb | 392 | foreach my $i (1, 2) { |
241416b8 DM |
393 | my $z = 1; |
394 | } | |
395 | #### | |
4da9a2ca FC |
396 | # OPTIONS -p |
397 | # foreach with my under -p | |
398 | foreach my $i (1) { | |
399 | die; | |
400 | } | |
401 | #### | |
507a68aa | 402 | # foreach |
241416b8 DM |
403 | my $i; |
404 | foreach $i (1, 2) { | |
405 | my $z = 1; | |
406 | } | |
407 | #### | |
507a68aa | 408 | # foreach, 2 mys |
241416b8 DM |
409 | my $i; |
410 | foreach my $i (1, 2) { | |
411 | my $z = 1; | |
412 | } | |
413 | #### | |
507a68aa | 414 | # foreach |
241416b8 DM |
415 | foreach my $i (1, 2) { |
416 | my $z = 1; | |
417 | } | |
418 | #### | |
507a68aa | 419 | # foreach with our |
241416b8 DM |
420 | foreach our $i (1, 2) { |
421 | my $z = 1; | |
422 | } | |
423 | #### | |
507a68aa | 424 | # foreach with my and our |
241416b8 DM |
425 | my $i; |
426 | foreach our $i (1, 2) { | |
427 | my $z = 1; | |
428 | } | |
3ac6e0f9 | 429 | #### |
507a68aa | 430 | # reverse sort |
3ac6e0f9 RGS |
431 | my @x; |
432 | print reverse sort(@x); | |
433 | #### | |
507a68aa | 434 | # sort with cmp |
3ac6e0f9 RGS |
435 | my @x; |
436 | print((sort {$b cmp $a} @x)); | |
437 | #### | |
507a68aa | 438 | # reverse sort with block |
3ac6e0f9 RGS |
439 | my @x; |
440 | print((reverse sort {$b <=> $a} @x)); | |
36d57d93 | 441 | #### |
507a68aa | 442 | # foreach reverse |
36d57d93 RGS |
443 | our @a; |
444 | print $_ foreach (reverse @a); | |
aae53c41 | 445 | #### |
507a68aa | 446 | # foreach reverse (not inplace) |
aae53c41 RGS |
447 | our @a; |
448 | print $_ foreach (reverse 1, 2..5); | |
f86ea535 | 449 | #### |
507a68aa | 450 | # bug #38684 |
f86ea535 SM |
451 | our @ary; |
452 | @ary = split(' ', 'foo', 0); | |
31c6271a | 453 | #### |
507a68aa | 454 | # bug #40055 |
31c6271a RD |
455 | do { () }; |
456 | #### | |
507a68aa | 457 | # bug #40055 |
31c6271a | 458 | do { my $x = 1; $x }; |
d9002312 | 459 | #### |
507a68aa | 460 | # <20061012113037.GJ25805@c4.convolution.nl> |
d9002312 SM |
461 | my $f = sub { |
462 | +{[]}; | |
463 | } ; | |
8b2d6640 | 464 | #### |
507a68aa | 465 | # bug #43010 |
8b2d6640 FC |
466 | '!@$%'->(); |
467 | #### | |
507a68aa | 468 | # bug #43010 |
8b2d6640 FC |
469 | ::(); |
470 | #### | |
507a68aa | 471 | # bug #43010 |
8b2d6640 FC |
472 | '::::'->(); |
473 | #### | |
507a68aa | 474 | # bug #43010 |
8b2d6640 | 475 | &::::; |
09d856fb | 476 | #### |
1b38d782 FC |
477 | # [perl #77172] |
478 | package rt77172; | |
479 | sub foo {} foo & & & foo; | |
480 | >>>> | |
481 | package rt77172; | |
482 | foo(&{&} & foo()); | |
483 | #### | |
507a68aa | 484 | # variables as method names |
09d856fb CK |
485 | my $bar; |
486 | 'Foo'->$bar('orz'); | |
35a99a08 | 487 | 'Foo'->$bar('orz') = 'a stranger stranger than before'; |
09d856fb | 488 | #### |
507a68aa | 489 | # constants as method names |
09d856fb CK |
490 | 'Foo'->bar('orz'); |
491 | #### | |
507a68aa | 492 | # constants as method names without () |
09d856fb | 493 | 'Foo'->bar; |
0ced6c29 | 494 | #### |
28bfcb02 | 495 | # [perl #47359] "indirect" method call notation |
1bf8bbb0 FC |
496 | our @bar; |
497 | foo{@bar}+1,->foo; | |
498 | (foo{@bar}+1),foo(); | |
499 | foo{@bar}1 xor foo(); | |
500 | >>>> | |
501 | our @bar; | |
502 | (foo { @bar } 1)->foo; | |
503 | (foo { @bar } 1), foo(); | |
504 | foo { @bar } 1 xor foo(); | |
505 | #### | |
e9c69003 | 506 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" |
205fef88 | 507 | # CONTEXT use feature ':5.10'; |
507a68aa | 508 | # say |
7ddd1a01 NC |
509 | say 'foo'; |
510 | #### | |
8f57bb34 | 511 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" |
8f57bb34 NC |
512 | # CONTEXT use 5.10.0; |
513 | # say in the context of use 5.10.0 | |
514 | say 'foo'; | |
515 | #### | |
516 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" | |
8f57bb34 NC |
517 | # say with use 5.10.0 |
518 | use 5.10.0; | |
519 | say 'foo'; | |
520 | >>>> | |
521 | no feature; | |
522 | use feature ':5.10'; | |
523 | say 'foo'; | |
524 | #### | |
525 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" | |
526 | # say with use feature ':5.10'; | |
527 | use feature ':5.10'; | |
528 | say 'foo'; | |
529 | >>>> | |
530 | use feature 'say', 'state', 'switch'; | |
531 | say 'foo'; | |
532 | #### | |
533 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" | |
8f57bb34 NC |
534 | # CONTEXT use feature ':5.10'; |
535 | # say with use 5.10.0 in the context of use feature | |
536 | use 5.10.0; | |
537 | say 'foo'; | |
538 | >>>> | |
539 | no feature; | |
540 | use feature ':5.10'; | |
541 | say 'foo'; | |
542 | #### | |
543 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" | |
544 | # CONTEXT use 5.10.0; | |
545 | # say with use feature ':5.10' in the context of use 5.10.0 | |
546 | use feature ':5.10'; | |
547 | say 'foo'; | |
548 | >>>> | |
549 | say 'foo'; | |
550 | #### | |
551 | # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" | |
552 | # CONTEXT use feature ':5.15'; | |
553 | # __SUB__ | |
554 | __SUB__; | |
555 | #### | |
556 | # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" | |
8f57bb34 NC |
557 | # CONTEXT use 5.15.0; |
558 | # __SUB__ in the context of use 5.15.0 | |
559 | __SUB__; | |
560 | #### | |
561 | # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" | |
8f57bb34 NC |
562 | # __SUB__ with use 5.15.0 |
563 | use 5.15.0; | |
564 | __SUB__; | |
565 | >>>> | |
566 | no feature; | |
567 | use feature ':5.16'; | |
568 | __SUB__; | |
569 | #### | |
570 | # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" | |
571 | # __SUB__ with use feature ':5.15'; | |
572 | use feature ':5.15'; | |
573 | __SUB__; | |
574 | >>>> | |
575 | use feature 'current_sub', 'evalbytes', 'fc', 'say', 'state', 'switch', 'unicode_strings', 'unicode_eval'; | |
576 | __SUB__; | |
577 | #### | |
578 | # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" | |
8f57bb34 NC |
579 | # CONTEXT use feature ':5.15'; |
580 | # __SUB__ with use 5.15.0 in the context of use feature | |
581 | use 5.15.0; | |
582 | __SUB__; | |
583 | >>>> | |
584 | no feature; | |
585 | use feature ':5.16'; | |
586 | __SUB__; | |
587 | #### | |
588 | # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version" | |
589 | # CONTEXT use 5.15.0; | |
590 | # __SUB__ with use feature ':5.15' in the context of use 5.15.0 | |
591 | use feature ':5.15'; | |
592 | __SUB__; | |
593 | >>>> | |
594 | __SUB__; | |
595 | #### | |
e9c69003 | 596 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
205fef88 | 597 | # CONTEXT use feature ':5.10'; |
507a68aa | 598 | # state vars |
0ced6c29 RGS |
599 | state $x = 42; |
600 | #### | |
e9c69003 | 601 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
205fef88 | 602 | # CONTEXT use feature ':5.10'; |
507a68aa | 603 | # state var assignment |
7ddd1a01 NC |
604 | { |
605 | my $y = (state $x = 42); | |
606 | } | |
607 | #### | |
e9c69003 | 608 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
205fef88 | 609 | # CONTEXT use feature ':5.10'; |
c4a6f826 | 610 | # state vars in anonymous subroutines |
7ddd1a01 NC |
611 | $a = sub { |
612 | state $x; | |
613 | return $x++; | |
614 | } | |
615 | ; | |
644741fd NC |
616 | #### |
617 | # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' | |
507a68aa | 618 | # each @array; |
644741fd NC |
619 | each @ARGV; |
620 | each @$a; | |
621 | #### | |
622 | # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' | |
507a68aa | 623 | # keys @array; values @array |
644741fd NC |
624 | keys @$a if keys @ARGV; |
625 | values @ARGV if values @$a; | |
35925e80 | 626 | #### |
507a68aa | 627 | # Anonymous arrays and hashes, and references to them |
35925e80 RGS |
628 | my $a = {}; |
629 | my $b = \{}; | |
630 | my $c = []; | |
631 | my $d = \[]; | |
9210de83 FR |
632 | #### |
633 | # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version" | |
0f539b13 | 634 | # CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch'; |
507a68aa | 635 | # implicit smartmatch in given/when |
9210de83 FR |
636 | given ('foo') { |
637 | when ('bar') { continue; } | |
638 | when ($_ ~~ 'quux') { continue; } | |
639 | default { 0; } | |
640 | } | |
7ecdd211 | 641 | #### |
507a68aa | 642 | # conditions in elsifs (regression in change #33710 which fixed bug #37302) |
7ecdd211 PJ |
643 | if ($a) { x(); } |
644 | elsif ($b) { x(); } | |
645 | elsif ($a and $b) { x(); } | |
646 | elsif ($a or $b) { x(); } | |
647 | else { x(); } | |
03b22f1b | 648 | #### |
507a68aa | 649 | # interpolation in regexps |
03b22f1b RGS |
650 | my($y, $t); |
651 | /x${y}z$t/; | |
227375e1 | 652 | #### |
4a4b8592 | 653 | # TODO new undocumented cpan-bug #33708 |
507a68aa | 654 | # cpan-bug #33708 |
227375e1 RU |
655 | %{$_ || {}} |
656 | #### | |
4a4b8592 | 657 | # TODO hash constants not yet fixed |
507a68aa | 658 | # cpan-bug #33708 |
227375e1 RU |
659 | use constant H => { "#" => 1 }; H->{"#"} |
660 | #### | |
4a4b8592 | 661 | # TODO optimized away 0 not yet fixed |
507a68aa | 662 | # cpan-bug #33708 |
227375e1 | 663 | foreach my $i (@_) { 0 } |
edbe35ea | 664 | #### |
507a68aa | 665 | # tests with not, not optimized |
07f3cdf5 | 666 | my $c; |
edbe35ea VP |
667 | x() unless $a; |
668 | x() if not $a and $b; | |
669 | x() if $a and not $b; | |
670 | x() unless not $a and $b; | |
671 | x() unless $a and not $b; | |
672 | x() if not $a or $b; | |
673 | x() if $a or not $b; | |
674 | x() unless not $a or $b; | |
675 | x() unless $a or not $b; | |
07f3cdf5 VP |
676 | x() if $a and not $b and $c; |
677 | x() if not $a and $b and not $c; | |
678 | x() unless $a and not $b and $c; | |
679 | x() unless not $a and $b and not $c; | |
680 | x() if $a or not $b or $c; | |
681 | x() if not $a or $b or not $c; | |
682 | x() unless $a or not $b or $c; | |
683 | x() unless not $a or $b or not $c; | |
edbe35ea | 684 | #### |
507a68aa | 685 | # tests with not, optimized |
07f3cdf5 | 686 | my $c; |
edbe35ea VP |
687 | x() if not $a; |
688 | x() unless not $a; | |
689 | x() if not $a and not $b; | |
690 | x() unless not $a and not $b; | |
691 | x() if not $a or not $b; | |
692 | x() unless not $a or not $b; | |
07f3cdf5 VP |
693 | x() if not $a and not $b and $c; |
694 | x() unless not $a and not $b and $c; | |
695 | x() if not $a or not $b or $c; | |
696 | x() unless not $a or not $b or $c; | |
697 | x() if not $a and not $b and not $c; | |
698 | x() unless not $a and not $b and not $c; | |
699 | x() if not $a or not $b or not $c; | |
700 | x() unless not $a or not $b or not $c; | |
701 | x() unless not $a or not $b or not $c; | |
edbe35ea | 702 | >>>> |
07f3cdf5 | 703 | my $c; |
edbe35ea VP |
704 | x() unless $a; |
705 | x() if $a; | |
706 | x() unless $a or $b; | |
707 | x() if $a or $b; | |
708 | x() unless $a and $b; | |
07f3cdf5 VP |
709 | x() if $a and $b; |
710 | x() if not $a || $b and $c; | |
711 | x() unless not $a || $b and $c; | |
712 | x() if not $a && $b or $c; | |
713 | x() unless not $a && $b or $c; | |
714 | x() unless $a or $b or $c; | |
715 | x() if $a or $b or $c; | |
716 | x() unless $a and $b and $c; | |
717 | x() if $a and $b and $c; | |
718 | x() unless not $a && $b && $c; | |
71c4dbc3 | 719 | #### |
507a68aa | 720 | # tests that should be constant folded |
71c4dbc3 VP |
721 | x() if 1; |
722 | x() if GLIPP; | |
723 | x() if !GLIPP; | |
724 | x() if GLIPP && GLIPP; | |
725 | x() if !GLIPP || GLIPP; | |
726 | x() if do { GLIPP }; | |
727 | x() if do { no warnings 'void'; 5; GLIPP }; | |
728 | x() if do { !GLIPP }; | |
729 | if (GLIPP) { x() } else { z() } | |
730 | if (!GLIPP) { x() } else { z() } | |
731 | if (GLIPP) { x() } elsif (GLIPP) { z() } | |
732 | if (!GLIPP) { x() } elsif (GLIPP) { z() } | |
733 | if (GLIPP) { x() } elsif (!GLIPP) { z() } | |
734 | if (!GLIPP) { x() } elsif (!GLIPP) { z() } | |
735 | if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() } | |
736 | if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() } | |
737 | if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() } | |
738 | >>>> | |
739 | x(); | |
740 | x(); | |
741 | '???'; | |
742 | x(); | |
743 | x(); | |
744 | x(); | |
745 | x(); | |
746 | do { | |
747 | '???' | |
748 | }; | |
749 | do { | |
750 | x() | |
751 | }; | |
752 | do { | |
753 | z() | |
754 | }; | |
755 | do { | |
756 | x() | |
757 | }; | |
758 | do { | |
759 | z() | |
760 | }; | |
761 | do { | |
762 | x() | |
763 | }; | |
764 | '???'; | |
765 | do { | |
766 | t() | |
767 | }; | |
768 | '???'; | |
769 | !1; | |
770 | #### | |
719c50dc RGS |
771 | # TODO constant deparsing has been backed out for 5.12 |
772 | # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads" | |
507a68aa | 773 | # tests that shouldn't be constant folded |
ac0f1413 NC |
774 | # It might be fundamentally impossible to make this work on ithreads, in which |
775 | # case the TODO should become a SKIP | |
71c4dbc3 VP |
776 | x() if $a; |
777 | if ($a == 1) { x() } elsif ($b == 2) { z() } | |
778 | if (do { foo(); GLIPP }) { x() } | |
779 | if (do { $a++; GLIPP }) { x() } | |
780 | >>>> | |
781 | x() if $a; | |
782 | if ($a == 1) { x(); } elsif ($b == 2) { z(); } | |
2990415a FR |
783 | if (do { foo(); GLIPP }) { x(); } |
784 | if (do { ++$a; GLIPP }) { x(); } | |
785 | #### | |
0fa4a265 | 786 | # TODO constant deparsing has been backed out for 5.12 |
507a68aa | 787 | # tests for deparsing constants |
2990415a FR |
788 | warn PI; |
789 | #### | |
0fa4a265 | 790 | # TODO constant deparsing has been backed out for 5.12 |
507a68aa | 791 | # tests for deparsing imported constants |
3779476a | 792 | warn O_TRUNC; |
2990415a | 793 | #### |
0fa4a265 | 794 | # TODO constant deparsing has been backed out for 5.12 |
507a68aa | 795 | # tests for deparsing re-exported constants |
2990415a FR |
796 | warn O_CREAT; |
797 | #### | |
0fa4a265 | 798 | # TODO constant deparsing has been backed out for 5.12 |
507a68aa | 799 | # tests for deparsing imported constants that got deleted from the original namespace |
aaf9c2b2 | 800 | warn O_APPEND; |
2990415a | 801 | #### |
0fa4a265 DM |
802 | # TODO constant deparsing has been backed out for 5.12 |
803 | # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads" | |
507a68aa | 804 | # tests for deparsing constants which got turned into full typeglobs |
ac0f1413 NC |
805 | # It might be fundamentally impossible to make this work on ithreads, in which |
806 | # case the TODO should become a SKIP | |
2990415a FR |
807 | warn O_EXCL; |
808 | eval '@Fcntl::O_EXCL = qw/affe tiger/;'; | |
809 | warn O_EXCL; | |
810 | #### | |
0fa4a265 | 811 | # TODO constant deparsing has been backed out for 5.12 |
507a68aa | 812 | # tests for deparsing of blessed constant with overloaded numification |
2990415a | 813 | warn OVERLOADED_NUMIFICATION; |
79289e05 | 814 | #### |
507a68aa | 815 | # strict |
79289e05 | 816 | no strict; |
415d4c68 FC |
817 | print $x; |
818 | use strict 'vars'; | |
819 | print $main::x; | |
820 | use strict 'subs'; | |
821 | print $main::x; | |
822 | use strict 'refs'; | |
823 | print $main::x; | |
824 | no strict 'vars'; | |
79289e05 NC |
825 | $x; |
826 | #### | |
827 | # TODO Subsets of warnings could be encoded textually, rather than as bitflips. | |
507a68aa | 828 | # subsets of warnings |
79289e05 NC |
829 | no warnings 'deprecated'; |
830 | my $x; | |
831 | #### | |
832 | # TODO Better test for CPAN #33708 - the deparsed code has different behaviour | |
507a68aa | 833 | # CPAN #33708 |
79289e05 NC |
834 | use strict; |
835 | no warnings; | |
836 | ||
837 | foreach (0..3) { | |
838 | my $x = 2; | |
839 | { | |
840 | my $x if 0; | |
841 | print ++$x, "\n"; | |
842 | } | |
843 | } | |
d83f38d8 | 844 | #### |
507a68aa | 845 | # no attribute list |
d83f38d8 NC |
846 | my $pi = 4; |
847 | #### | |
2dc78664 NC |
848 | # SKIP ?$] > 5.013006 && ":= is now a syntax error" |
849 | # := treated as an empty attribute list | |
d83f38d8 NC |
850 | no warnings; |
851 | my $pi := 4; | |
852 | >>>> | |
853 | no warnings; | |
854 | my $pi = 4; | |
855 | #### | |
507a68aa | 856 | # : = empty attribute list |
d83f38d8 NC |
857 | my $pi : = 4; |
858 | >>>> | |
859 | my $pi = 4; | |
689e417f | 860 | #### |
507a68aa | 861 | # in place sort |
689e417f VP |
862 | our @a; |
863 | my @b; | |
864 | @a = sort @a; | |
865 | @b = sort @b; | |
866 | (); | |
867 | #### | |
507a68aa | 868 | # in place reverse |
689e417f VP |
869 | our @a; |
870 | my @b; | |
871 | @a = reverse @a; | |
872 | @b = reverse @b; | |
873 | (); | |
06fc6867 | 874 | #### |
507a68aa | 875 | # #71870 Use of uninitialized value in bitwise and B::Deparse |
06fc6867 VP |
876 | my($r, $s, @a); |
877 | @a = split(/foo/, $s, 0); | |
878 | $r = qr/foo/; | |
879 | @a = split(/$r/, $s, 0); | |
880 | (); | |
98a1a137 | 881 | #### |
507a68aa | 882 | # package declaration before label |
98a1a137 Z |
883 | { |
884 | package Foo; | |
885 | label: print 123; | |
886 | } | |
538f5756 | 887 | #### |
507a68aa | 888 | # shift optimisation |
538f5756 RZ |
889 | shift; |
890 | >>>> | |
891 | shift(); | |
892 | #### | |
507a68aa | 893 | # shift optimisation |
538f5756 RZ |
894 | shift @_; |
895 | #### | |
507a68aa | 896 | # shift optimisation |
538f5756 RZ |
897 | pop; |
898 | >>>> | |
899 | pop(); | |
900 | #### | |
507a68aa | 901 | # shift optimisation |
538f5756 | 902 | pop @_; |
a539498a | 903 | #### |
507a68aa | 904 | #[perl #20444] |
a539498a FC |
905 | "foo" =~ (1 ? /foo/ : /bar/); |
906 | "foo" =~ (1 ? y/foo// : /bar/); | |
5e5a1632 | 907 | "foo" =~ (1 ? y/foo//r : /bar/); |
a539498a FC |
908 | "foo" =~ (1 ? s/foo// : /bar/); |
909 | >>>> | |
910 | 'foo' =~ ($_ =~ /foo/); | |
911 | 'foo' =~ ($_ =~ tr/fo//); | |
5e5a1632 | 912 | 'foo' =~ ($_ =~ tr/fo//r); |
a539498a | 913 | 'foo' =~ ($_ =~ s/foo//); |
e0ab66ad | 914 | #### |
5e5a1632 FC |
915 | # The fix for [perl #20444] broke this. |
916 | 'foo' =~ do { () }; | |
917 | #### | |
4b58603b FC |
918 | # [perl #81424] match against aelemfast_lex |
919 | my @s; | |
920 | print /$s[1]/; | |
921 | #### | |
36727b53 FC |
922 | # /$#a/ |
923 | print /$#main::a/; | |
924 | #### | |
b9bc576f | 925 | # [perl #91318] /regexp/applaud |
09622ee2 FC |
926 | print /a/a, s/b/c/a; |
927 | print /a/aa, s/b/c/aa; | |
928 | print /a/p, s/b/c/p; | |
929 | print /a/l, s/b/c/l; | |
930 | print /a/u, s/b/c/u; | |
b9bc576f FC |
931 | { |
932 | use feature "unicode_strings"; | |
09622ee2 | 933 | print /a/d, s/b/c/d; |
b9bc576f FC |
934 | } |
935 | { | |
936 | use re "/u"; | |
09622ee2 | 937 | print /a/d, s/b/c/d; |
b9bc576f | 938 | } |
dff5ffe4 FC |
939 | { |
940 | use 5.012; | |
941 | print /a/d, s/b/c/d; | |
942 | } | |
b9bc576f | 943 | >>>> |
09622ee2 FC |
944 | print /a/a, s/b/c/a; |
945 | print /a/aa, s/b/c/aa; | |
946 | print /a/p, s/b/c/p; | |
947 | print /a/l, s/b/c/l; | |
948 | print /a/u, s/b/c/u; | |
b9bc576f | 949 | { |
a8095af7 | 950 | use feature 'unicode_strings'; |
09622ee2 | 951 | print /a/d, s/b/c/d; |
b9bc576f FC |
952 | } |
953 | { | |
0bb01b05 FC |
954 | BEGIN { $^H{'reflags'} = '0'; |
955 | $^H{'reflags_charset'} = '2'; } | |
09622ee2 | 956 | print /a/d, s/b/c/d; |
b9bc576f | 957 | } |
dff5ffe4 FC |
958 | { |
959 | no feature; | |
960 | use feature ':5.12'; | |
961 | print /a/d, s/b/c/d; | |
962 | } | |
b9bc576f | 963 | #### |
9f125c4a FC |
964 | # [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns) |
965 | s/foo/\(3);/eg; | |
966 | #### | |
e0ab66ad NC |
967 | # Test @threadsv_names under 5005threads |
968 | foreach $' (1, 2) { | |
969 | sleep $'; | |
970 | } | |
e7afc405 FC |
971 | #### |
972 | # y///r | |
973 | tr/a/b/r; | |
cb8157e3 | 974 | #### |
cb8578ff | 975 | # [perl #90898] |
f4002a4b | 976 | <a,>; |
09dcfa7d FC |
977 | #### |
978 | # [perl #91008] | |
a69823cd | 979 | # CONTEXT no warnings 'experimental::aggref'; |
09dcfa7d FC |
980 | each $@; |
981 | keys $~; | |
982 | values $!; | |
5d8c42c2 FC |
983 | #### |
984 | # readpipe with complex expression | |
985 | readpipe $a + $b; | |
93bad3fd NC |
986 | #### |
987 | # aelemfast | |
988 | $b::a[0] = 1; | |
989 | #### | |
990 | # aelemfast for a lexical | |
991 | my @a; | |
992 | $a[0] = 1; | |
80e3f4ad FC |
993 | #### |
994 | # feature features without feature | |
0f539b13 | 995 | # CONTEXT no warnings 'experimental::smartmatch'; |
80e3f4ad | 996 | CORE::state $x; |
223b1722 FC |
997 | CORE::say $x; |
998 | CORE::given ($x) { | |
999 | CORE::when (3) { | |
1000 | continue; | |
1001 | } | |
1002 | CORE::default { | |
1003 | CORE::break; | |
1004 | } | |
1005 | } | |
1006 | CORE::evalbytes ''; | |
1007 | () = CORE::__SUB__; | |
838f2281 | 1008 | () = CORE::fc $x; |
223b1722 FC |
1009 | #### |
1010 | # feature features when feature has been disabled by use VERSION | |
0f539b13 | 1011 | # CONTEXT no warnings 'experimental::smartmatch'; |
223b1722 FC |
1012 | use feature (sprintf(":%vd", $^V)); |
1013 | use 1; | |
1014 | CORE::state $x; | |
1015 | CORE::say $x; | |
1016 | CORE::given ($x) { | |
1017 | CORE::when (3) { | |
1018 | continue; | |
1019 | } | |
1020 | CORE::default { | |
1021 | CORE::break; | |
1022 | } | |
1023 | } | |
1024 | CORE::evalbytes ''; | |
1025 | () = CORE::__SUB__; | |
1026 | >>>> | |
205fef88 NC |
1027 | CORE::state $x; |
1028 | CORE::say $x; | |
1029 | CORE::given ($x) { | |
1030 | CORE::when (3) { | |
1031 | continue; | |
1032 | } | |
1033 | CORE::default { | |
1034 | CORE::break; | |
1035 | } | |
1036 | } | |
1037 | CORE::evalbytes ''; | |
1038 | () = CORE::__SUB__; | |
1039 | #### | |
1040 | # (the above test with CONTEXT, and the output is equivalent but different) | |
0f539b13 | 1041 | # CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch'; |
205fef88 NC |
1042 | # feature features when feature has been disabled by use VERSION |
1043 | use feature (sprintf(":%vd", $^V)); | |
1044 | use 1; | |
1045 | CORE::state $x; | |
1046 | CORE::say $x; | |
1047 | CORE::given ($x) { | |
1048 | CORE::when (3) { | |
1049 | continue; | |
1050 | } | |
1051 | CORE::default { | |
1052 | CORE::break; | |
1053 | } | |
1054 | } | |
1055 | CORE::evalbytes ''; | |
1056 | () = CORE::__SUB__; | |
1057 | >>>> | |
0bb01b05 FC |
1058 | no feature; |
1059 | use feature ':default'; | |
223b1722 | 1060 | CORE::state $x; |
80e3f4ad FC |
1061 | CORE::say $x; |
1062 | CORE::given ($x) { | |
1063 | CORE::when (3) { | |
1064 | continue; | |
1065 | } | |
1066 | CORE::default { | |
e36901c8 | 1067 | CORE::break; |
80e3f4ad FC |
1068 | } |
1069 | } | |
7d789282 | 1070 | CORE::evalbytes ''; |
84ed0108 | 1071 | () = CORE::__SUB__; |
6ec73527 | 1072 | #### |
0bb01b05 FC |
1073 | # Feature hints |
1074 | use feature 'current_sub', 'evalbytes'; | |
1075 | print; | |
1076 | use 1; | |
1077 | print; | |
1078 | use 5.014; | |
1079 | print; | |
1080 | no feature 'unicode_strings'; | |
1081 | print; | |
1082 | >>>> | |
a8095af7 | 1083 | use feature 'current_sub', 'evalbytes'; |
0bb01b05 FC |
1084 | print $_; |
1085 | no feature; | |
1086 | use feature ':default'; | |
1087 | print $_; | |
1088 | no feature; | |
1089 | use feature ':5.12'; | |
1090 | print $_; | |
a8095af7 | 1091 | no feature 'unicode_strings'; |
0bb01b05 FC |
1092 | print $_; |
1093 | #### | |
6ec73527 FC |
1094 | # $#- $#+ $#{%} etc. |
1095 | my @x; | |
5b6da579 | 1096 | @x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*}); |
6ec73527 FC |
1097 | @x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,}); |
1098 | @x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-); | |
1099 | @x = ($#{;}, $#{:}); | |
61154ac0 | 1100 | #### |
ff683671 NC |
1101 | # ${#} interpolated |
1102 | # It's a known TODO that warnings are deparsed as bits, not textually. | |
1103 | no warnings; | |
61154ac0 | 1104 | () = "${#}a"; |
958ed56b | 1105 | #### |
337d7381 FC |
1106 | # [perl #86060] $( $| $) in regexps need braces |
1107 | /${(}/; | |
1108 | /${|}/; | |
1109 | /${)}/; | |
1110 | /${(}${|}${)}/; | |
1111 | #### | |
958ed56b FC |
1112 | # ()[...] |
1113 | my(@a) = ()[()]; | |
521795fe FC |
1114 | #### |
1115 | # sort(foo(bar)) | |
1116 | # sort(foo(bar)) is interpreted as sort &foo(bar) | |
1117 | # sort foo(bar) is interpreted as sort foo bar | |
1118 | # parentheses are not optional in this case | |
1119 | print sort(foo('bar')); | |
1120 | >>>> | |
1121 | print sort(foo('bar')); | |
24fcb59f FC |
1122 | #### |
1123 | # substr assignment | |
1124 | substr(my $a, 0, 0) = (foo(), bar()); | |
1125 | $a++; | |
04be0204 | 1126 | #### |
d1718a7c FC |
1127 | # This following line works around an unfixed bug that we are not trying to |
1128 | # test for here: | |
1129 | # CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised | |
04be0204 FC |
1130 | # hint hash |
1131 | BEGIN { $^H{'foo'} = undef; } | |
1132 | { | |
1133 | BEGIN { $^H{'bar'} = undef; } | |
1134 | { | |
1135 | BEGIN { $^H{'baz'} = undef; } | |
1136 | { | |
1137 | print $_; | |
1138 | } | |
1139 | print $_; | |
1140 | } | |
1141 | print $_; | |
1142 | } | |
035146a3 FC |
1143 | BEGIN { $^H{q[']} = '('; } |
1144 | print $_; | |
c306e834 | 1145 | #### |
d1718a7c FC |
1146 | # This following line works around an unfixed bug that we are not trying to |
1147 | # test for here: | |
1148 | # CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised | |
c306e834 FC |
1149 | # hint hash changes that serialise the same way with sort %hh |
1150 | BEGIN { $^H{'a'} = 'b'; } | |
1151 | { | |
1152 | BEGIN { $^H{'b'} = 'a'; delete $^H{'a'}; } | |
1153 | print $_; | |
1154 | } | |
1155 | print $_; | |
94bb57f9 FC |
1156 | #### |
1157 | # [perl #47361] do({}) and do +{} (variants of do-file) | |
1158 | do({}); | |
1159 | do +{}; | |
8b46c09b FC |
1160 | sub foo::do {} |
1161 | package foo; | |
1162 | CORE::do({}); | |
1163 | CORE::do +{}; | |
94bb57f9 FC |
1164 | >>>> |
1165 | do({}); | |
1166 | do({}); | |
8b46c09b FC |
1167 | package foo; |
1168 | CORE::do({}); | |
1169 | CORE::do({}); | |
9c56d9ea FC |
1170 | #### |
1171 | # [perl #77096] functions that do not follow the llafr | |
1172 | () = (return 1) + time; | |
1173 | () = (return ($1 + $2) * $3) + time; | |
1174 | () = (return ($a xor $b)) + time; | |
1175 | () = (do 'file') + time; | |
1176 | () = (do ($1 + $2) * $3) + time; | |
1177 | () = (do ($1 xor $2)) + time; | |
41df74e3 FC |
1178 | () = (goto 1) + 3; |
1179 | () = (require 'foo') + 3; | |
1180 | () = (require foo) + 3; | |
266da325 | 1181 | () = (CORE::dump 1) + 3; |
41df74e3 FC |
1182 | () = (last 1) + 3; |
1183 | () = (next 1) + 3; | |
1184 | () = (redo 1) + 3; | |
5830412d FC |
1185 | () = (-R $_) + 3; |
1186 | () = (-W $_) + 3; | |
1187 | () = (-X $_) + 3; | |
1188 | () = (-r $_) + 3; | |
1189 | () = (-w $_) + 3; | |
1190 | () = (-x $_) + 3; | |
2462c3cc | 1191 | #### |
1cabb3b3 FC |
1192 | # [perl #97476] not() *does* follow the llafr |
1193 | $_ = ($a xor not +($1 || 2) ** 2); | |
1194 | #### | |
4d8ac5c7 FC |
1195 | # Precedence conundrums with argument-less function calls |
1196 | () = (eof) + 1; | |
1197 | () = (return) + 1; | |
1198 | () = (return, 1); | |
7bc8c979 FC |
1199 | () = warn; |
1200 | () = warn() + 1; | |
4d8ac5c7 FC |
1201 | () = setpgrp() + 1; |
1202 | #### | |
1eb0b7be FC |
1203 | # loopexes have assignment prec |
1204 | () = (CORE::dump a) | 'b'; | |
1205 | () = (goto a) | 'b'; | |
1206 | () = (last a) | 'b'; | |
1207 | () = (next a) | 'b'; | |
1208 | () = (redo a) | 'b'; | |
1209 | #### | |
2462c3cc FC |
1210 | # [perl #63558] open local(*FH) |
1211 | open local *FH; | |
564cd6cb | 1212 | pipe local *FH, local *FH; |
843b15cc | 1213 | #### |
b89b7257 FC |
1214 | # [perl #91416] open "string" |
1215 | open 'open'; | |
1216 | open '####'; | |
1217 | open '^A'; | |
1218 | open "\ca"; | |
1219 | >>>> | |
1220 | open *open; | |
1221 | open '####'; | |
1222 | open '^A'; | |
1223 | open *^A; | |
1224 | #### | |
be6cf5cf FC |
1225 | # "string"->[] ->{} |
1226 | no strict 'vars'; | |
1227 | () = 'open'->[0]; #aelemfast | |
1228 | () = '####'->[0]; | |
1229 | () = '^A'->[0]; | |
1230 | () = "\ca"->[0]; | |
b861b87f | 1231 | () = 'a::]b'->[0]; |
10e8e32b FC |
1232 | () = 'open'->[$_]; #aelem |
1233 | () = '####'->[$_]; | |
1234 | () = '^A'->[$_]; | |
1235 | () = "\ca"->[$_]; | |
b861b87f | 1236 | () = 'a::]b'->[$_]; |
10e8e32b FC |
1237 | () = 'open'->{0}; #helem |
1238 | () = '####'->{0}; | |
1239 | () = '^A'->{0}; | |
1240 | () = "\ca"->{0}; | |
b861b87f | 1241 | () = 'a::]b'->{0}; |
be6cf5cf | 1242 | >>>> |
415d4c68 | 1243 | no strict 'vars'; |
be6cf5cf FC |
1244 | () = $open[0]; |
1245 | () = '####'->[0]; | |
1246 | () = '^A'->[0]; | |
1247 | () = $^A[0]; | |
b861b87f | 1248 | () = 'a::]b'->[0]; |
10e8e32b FC |
1249 | () = $open[$_]; |
1250 | () = '####'->[$_]; | |
1251 | () = '^A'->[$_]; | |
1252 | () = $^A[$_]; | |
b861b87f | 1253 | () = 'a::]b'->[$_]; |
10e8e32b FC |
1254 | () = $open{'0'}; |
1255 | () = '####'->{'0'}; | |
1256 | () = '^A'->{'0'}; | |
1257 | () = $^A{'0'}; | |
b861b87f | 1258 | () = 'a::]b'->{'0'}; |
be6cf5cf | 1259 | #### |
843b15cc FC |
1260 | # [perl #74740] -(f()) vs -f() |
1261 | $_ = -(f()); | |
c75b4828 FC |
1262 | #### |
1263 | # require <binop> | |
1264 | require 'a' . $1; | |
afb60448 HY |
1265 | #### |
1266 | #[perl #30504] foreach-my postfix/prefix difference | |
1267 | $_ = 'foo' foreach my ($foo1, $bar1, $baz1); | |
1268 | foreach (my ($foo2, $bar2, $baz2)) { $_ = 'foo' } | |
1269 | foreach my $i (my ($foo3, $bar3, $baz3)) { $i = 'foo' } | |
1270 | >>>> | |
1271 | $_ = 'foo' foreach (my($foo1, $bar1, $baz1)); | |
1272 | foreach $_ (my($foo2, $bar2, $baz2)) { | |
1273 | $_ = 'foo'; | |
1274 | } | |
1275 | foreach my $i (my($foo3, $bar3, $baz3)) { | |
1276 | $i = 'foo'; | |
1277 | } | |
1278 | #### | |
1279 | #[perl #108224] foreach with continue block | |
1280 | foreach (1 .. 3) { print } continue { print "\n" } | |
1281 | foreach (1 .. 3) { } continue { } | |
1282 | foreach my $i (1 .. 3) { print $i } continue { print "\n" } | |
1283 | foreach my $i (1 .. 3) { } continue { } | |
1284 | >>>> | |
1285 | foreach $_ (1 .. 3) { | |
1286 | print $_; | |
1287 | } | |
1288 | continue { | |
1289 | print "\n"; | |
1290 | } | |
1291 | foreach $_ (1 .. 3) { | |
1292 | (); | |
1293 | } | |
1294 | continue { | |
1295 | (); | |
1296 | } | |
1297 | foreach my $i (1 .. 3) { | |
1298 | print $i; | |
1299 | } | |
1300 | continue { | |
1301 | print "\n"; | |
1302 | } | |
1303 | foreach my $i (1 .. 3) { | |
1304 | (); | |
1305 | } | |
1306 | continue { | |
1307 | (); | |
1308 | } | |
bc1cc2c3 DM |
1309 | #### |
1310 | # file handles | |
1311 | no strict; | |
1312 | my $mfh; | |
1313 | open F; | |
1314 | open *F; | |
1315 | open $fh; | |
1316 | open $mfh; | |
1317 | open 'a+b'; | |
1318 | select *F; | |
1319 | select F; | |
1320 | select $f; | |
1321 | select $mfh; | |
1322 | select 'a+b'; | |
a7fd8ef6 DM |
1323 | #### |
1324 | # 'my' works with padrange op | |
1325 | my($z, @z); | |
1326 | my $m1; | |
1327 | $m1 = 1; | |
1328 | $z = $m1; | |
1329 | my $m2 = 2; | |
1330 | my($m3, $m4); | |
1331 | ($m3, $m4) = (1, 2); | |
1332 | @z = ($m3, $m4); | |
1333 | my($m5, $m6) = (1, 2); | |
1334 | my($m7, undef, $m8) = (1, 2, 3); | |
1335 | @z = ($m7, undef, $m8); | |
1336 | ($m7, undef, $m8) = (1, 2, 3); | |
1337 | #### | |
1338 | # 'our/local' works with padrange op | |
1339 | no strict; | |
1340 | our($z, @z); | |
1341 | our $o1; | |
1342 | local $o11; | |
1343 | $o1 = 1; | |
1344 | local $o1 = 1; | |
1345 | $z = $o1; | |
1346 | $z = local $o1; | |
1347 | our $o2 = 2; | |
1348 | our($o3, $o4); | |
1349 | ($o3, $o4) = (1, 2); | |
1350 | local($o3, $o4) = (1, 2); | |
1351 | @z = ($o3, $o4); | |
1352 | @z = local($o3, $o4); | |
1353 | our($o5, $o6) = (1, 2); | |
1354 | our($o7, undef, $o8) = (1, 2, 3); | |
1355 | @z = ($o7, undef, $o8); | |
1356 | @z = local($o7, undef, $o8); | |
1357 | ($o7, undef, $o8) = (1, 2, 3); | |
1358 | local($o7, undef, $o8) = (1, 2, 3); | |
1359 | #### | |
1360 | # 'state' works with padrange op | |
1361 | no strict; | |
1362 | use feature 'state'; | |
1363 | state($z, @z); | |
1364 | state $s1; | |
1365 | $s1 = 1; | |
1366 | $z = $s1; | |
1367 | state $s2 = 2; | |
1368 | state($s3, $s4); | |
1369 | ($s3, $s4) = (1, 2); | |
1370 | @z = ($s3, $s4); | |
1371 | # assignment of state lists isn't implemented yet | |
1372 | #state($s5, $s6) = (1, 2); | |
1373 | #state($s7, undef, $s8) = (1, 2, 3); | |
1374 | #@z = ($s7, undef, $s8); | |
1375 | ($s7, undef, $s8) = (1, 2, 3); | |
1376 | #### | |
1377 | # anon lists with padrange | |
1378 | my($a, $b); | |
1379 | my $c = [$a, $b]; | |
1380 | my $d = {$a, $b}; | |
1381 | #### | |
1382 | # slices with padrange | |
1383 | my($a, $b); | |
1384 | my(@x, %y); | |
1385 | @x = @x[$a, $b]; | |
1386 | @x = @y{$a, $b}; | |
1387 | #### | |
1388 | # binops with padrange | |
1389 | my($a, $b, $c); | |
1390 | $c = $a cmp $b; | |
1391 | $c = $a + $b; | |
1392 | $a += $b; | |
1393 | $c = $a - $b; | |
1394 | $a -= $b; | |
1395 | $c = my $a1 cmp $b; | |
1396 | $c = my $a2 + $b; | |
1397 | $a += my $b1; | |
1398 | $c = my $a3 - $b; | |
1399 | $a -= my $b2; | |
1400 | #### | |
1401 | # 'x' with padrange | |
1402 | my($a, $b, $c, $d, @e); | |
1403 | $c = $a x $b; | |
1404 | $a x= $b; | |
1405 | @e = ($a) x $d; | |
1406 | @e = ($a, $b) x $d; | |
1407 | @e = ($a, $b, $c) x $d; | |
1408 | @e = ($a, 1) x $d; | |
d5524600 DM |
1409 | #### |
1410 | # @_ with padrange | |
1411 | my($a, $b, $c) = @_; | |
ce4062e7 AC |
1412 | #### |
1413 | # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" | |
1414 | # TODO unimplemented in B::Deparse; RT #116553 | |
1415 | # lexical subroutine | |
1416 | use feature 'lexical_subs'; | |
601448c3 | 1417 | no warnings "experimental::lexical_subs"; |
ce4062e7 AC |
1418 | my sub f {} |
1419 | print f(); | |
f0cf3754 AC |
1420 | #### |
1421 | # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" | |
1422 | # TODO unimplemented in B::Deparse; RT #116553 | |
1423 | # lexical "state" subroutine | |
1424 | use feature 'state', 'lexical_subs'; | |
1425 | no warnings 'experimental::lexical_subs'; | |
1426 | state sub f {} | |
1427 | print f(); | |
bcbe2b27 FC |
1428 | #### |
1429 | # Elements of %# should not be confused with $#{ array } | |
1430 | () = ${#}{'foo'}; |