| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 4 | unshift @INC, 't'; |
| 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 | } |
| 10 | } |
| 11 | |
| 12 | use warnings; |
| 13 | use strict; |
| 14 | use Test::More; |
| 15 | |
| 16 | my $tests = 25; # not counting those in the __DATA__ section |
| 17 | |
| 18 | use B::Deparse; |
| 19 | my $deparse = B::Deparse->new(); |
| 20 | isa_ok($deparse, 'B::Deparse', 'instantiate a B::Deparse object'); |
| 21 | my %deparse; |
| 22 | |
| 23 | $/ = "\n####\n"; |
| 24 | while (<DATA>) { |
| 25 | chomp; |
| 26 | $tests ++; |
| 27 | # This code is pinched from the t/lib/common.pl for TODO. |
| 28 | # It's not clear how to avoid duplication |
| 29 | my %meta = (context => ''); |
| 30 | foreach my $what (qw(skip todo context options)) { |
| 31 | s/^#\s*\U$what\E\s*(.*)\n//m and $meta{$what} = $1; |
| 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 |
| 34 | if ($meta{$what} && $meta{$what} =~ s/^\?//) { |
| 35 | my $temp = eval $meta{$what}; |
| 36 | if ($@) { |
| 37 | die "# In \U$what\E code reason:\n# $meta{$what}\n$@"; |
| 38 | } |
| 39 | $meta{$what} = $temp; |
| 40 | } |
| 41 | } |
| 42 | |
| 43 | s/^\s*#\s*(.*)$//mg; |
| 44 | my $desc = $1; |
| 45 | die "Missing name in test $_" unless defined $desc; |
| 46 | |
| 47 | if ($meta{skip}) { |
| 48 | # Like this to avoid needing a label SKIP: |
| 49 | Test::More->builder->skip($meta{skip}); |
| 50 | next; |
| 51 | } |
| 52 | |
| 53 | my ($input, $expected); |
| 54 | if (/(.*)\n>>>>\n(.*)/s) { |
| 55 | ($input, $expected) = ($1, $2); |
| 56 | } |
| 57 | else { |
| 58 | ($input, $expected) = ($_, $_); |
| 59 | } |
| 60 | |
| 61 | # parse options if necessary |
| 62 | my $deparse = $meta{options} |
| 63 | ? $deparse{$meta{options}} ||= |
| 64 | new B::Deparse split /,/, $meta{options} |
| 65 | : $deparse; |
| 66 | |
| 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 |
| 79 | |
| 80 | if ($@) { |
| 81 | is($@, "", "compilation of $desc"); |
| 82 | } |
| 83 | else { |
| 84 | my $deparsed = $deparse->coderef2text( $coderef ); |
| 85 | my $regex = $expected; |
| 86 | $regex =~ s/(\S+)/\Q$1/g; |
| 87 | $regex =~ s/\s+/\\s+/g; |
| 88 | $regex = '^\{\s*' . $regex . '\s*\}$'; |
| 89 | |
| 90 | local $::TODO = $meta{todo}; |
| 91 | like($deparsed, qr/$regex/, $desc); |
| 92 | } |
| 93 | } |
| 94 | |
| 95 | use constant 'c', 'stuff'; |
| 96 | is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff', |
| 97 | 'the subroutine generated by use constant deparses'); |
| 98 | |
| 99 | my $a = 0; |
| 100 | is($deparse->coderef2text(sub{(-1) ** $a }), "{\n (-1) ** \$a;\n}", |
| 101 | 'anon sub capturing an external lexical'); |
| 102 | |
| 103 | use constant cr => ['hello']; |
| 104 | my $string = "sub " . $deparse->coderef2text(\&cr); |
| 105 | my $val = (eval $string)->() or diag $string; |
| 106 | is(ref($val), 'ARRAY', 'constant array references deparse'); |
| 107 | is($val->[0], 'hello', 'and return the correct value'); |
| 108 | |
| 109 | my $path = join " ", map { qq["-I$_"] } @INC; |
| 110 | |
| 111 | $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 2>&1`; |
| 112 | $a =~ s/-e syntax OK\n//g; |
| 113 | $a =~ s/.*possible typo.*\n//; # Remove warning line |
| 114 | $a =~ s/.*-i used with no filenames.*\n//; # Remove warning line |
| 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'; |
| 118 | BEGIN { $^I = ".bak"; } |
| 119 | BEGIN { $^W = 1; } |
| 120 | BEGIN { $/ = "\n"; $\ = "\n"; } |
| 121 | LINE: while (defined($_ = <ARGV>)) { |
| 122 | chomp $_; |
| 123 | our(@F) = split(' ', $_, 0); |
| 124 | '???'; |
| 125 | } |
| 126 | EOF |
| 127 | is($a, $b, |
| 128 | 'command line flags deparse as BEGIN blocks setting control variables'); |
| 129 | |
| 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 | |
| 135 | #Re: perlbug #35857, patch #24505 |
| 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 { |
| 142 | my $deparser = B::Deparse->new(); |
| 143 | return $deparser->coderef2text(shift); |
| 144 | } |
| 145 | |
| 146 | package Moo; |
| 147 | use overload '0+' => sub { 42 }; |
| 148 | |
| 149 | package main; |
| 150 | use strict; |
| 151 | use warnings; |
| 152 | use constant GLIPP => 'glipp'; |
| 153 | use constant PI => 4; |
| 154 | use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo'); |
| 155 | use Fcntl qw/O_TRUNC O_APPEND O_EXCL/; |
| 156 | BEGIN { delete $::Fcntl::{O_APPEND}; } |
| 157 | use POSIX qw/O_CREAT/; |
| 158 | sub test { |
| 159 | my $val = shift; |
| 160 | my $res = B::Deparse::Wrapper::getcode($val); |
| 161 | like($res, qr/use warnings/, |
| 162 | '[perl #35857] [PATCH] B::Deparse doesnt handle warnings register properly'); |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 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 | |
| 230 | # [perl #93990] |
| 231 | @] = (); |
| 232 | is($deparse->coderef2text(sub{ print "@{]}" }), |
| 233 | q<{ |
| 234 | print "@{]}"; |
| 235 | }>, 'curly around to interpolate "@{]}"'); |
| 236 | is($deparse->coderef2text(sub{ print "@{-}" }), |
| 237 | q<{ |
| 238 | print "@-"; |
| 239 | }>, 'no need to curly around to interpolate "@-"'); |
| 240 | |
| 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 | |
| 247 | # ambient_pragmas should not mess with strict settings. |
| 248 | SKIP: { |
| 249 | skip "requires 5.11", 1 unless $] >= 5.011; |
| 250 | eval q` |
| 251 | BEGIN { |
| 252 | # Clear out all hints |
| 253 | %^H = (); |
| 254 | $^H = 0; |
| 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 | |
| 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; |
| 266 | is($a, <<'EOCODH', 'multiple statements on format lines'); |
| 267 | format STDOUT = |
| 268 | @ |
| 269 | x(); z() |
| 270 | . |
| 271 | EOCODH |
| 272 | |
| 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 | |
| 278 | # literal big chars under 'use utf8' |
| 279 | is($deparse->coderef2text(sub{ use utf8; /€/; }), |
| 280 | '{ |
| 281 | /\x{20ac}/; |
| 282 | }', |
| 283 | "qr/euro/"); |
| 284 | |
| 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 | |
| 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 | |
| 312 | |
| 313 | done_testing($tests); |
| 314 | |
| 315 | __DATA__ |
| 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 | #### |
| 323 | # A constant |
| 324 | 1; |
| 325 | #### |
| 326 | # Constants in a block |
| 327 | { |
| 328 | no warnings; |
| 329 | '???'; |
| 330 | 2; |
| 331 | } |
| 332 | #### |
| 333 | # Lexical and simple arithmetic |
| 334 | my $test; |
| 335 | ++$test and $test /= 2; |
| 336 | >>>> |
| 337 | my $test; |
| 338 | $test /= 2 if ++$test; |
| 339 | #### |
| 340 | # list x |
| 341 | -((1, 2) x 2); |
| 342 | #### |
| 343 | # lvalue sub |
| 344 | { |
| 345 | my $test = sub : lvalue { |
| 346 | my $x; |
| 347 | } |
| 348 | ; |
| 349 | } |
| 350 | #### |
| 351 | # method |
| 352 | { |
| 353 | my $test = sub : method { |
| 354 | my $x; |
| 355 | } |
| 356 | ; |
| 357 | } |
| 358 | #### |
| 359 | # block with continue |
| 360 | { |
| 361 | 234; |
| 362 | } |
| 363 | continue { |
| 364 | 123; |
| 365 | } |
| 366 | #### |
| 367 | # lexical and package scalars |
| 368 | my $x; |
| 369 | print $main::x; |
| 370 | #### |
| 371 | # lexical and package arrays |
| 372 | my @x; |
| 373 | print $main::x[1]; |
| 374 | #### |
| 375 | # lexical and package hashes |
| 376 | my %x; |
| 377 | $x{warn()}; |
| 378 | #### |
| 379 | # our (LIST) |
| 380 | our($foo, $bar, $baz); |
| 381 | #### |
| 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 | #### |
| 397 | # local our |
| 398 | local our $rhubarb; |
| 399 | local our($rhu, $barb); |
| 400 | #### |
| 401 | # <> |
| 402 | my $foo; |
| 403 | $_ .= <ARGV> . <$foo>; |
| 404 | #### |
| 405 | # \x{} |
| 406 | my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ"; |
| 407 | #### |
| 408 | # s///e |
| 409 | s/x/'y';/e; |
| 410 | s/x/$a;/e; |
| 411 | s/x/complex_expression();/e; |
| 412 | #### |
| 413 | # block |
| 414 | { my $x; } |
| 415 | #### |
| 416 | # while 1 |
| 417 | while (1) { my $k; } |
| 418 | #### |
| 419 | # trailing for |
| 420 | my ($x,@a); |
| 421 | $x=1 for @a; |
| 422 | >>>> |
| 423 | my($x, @a); |
| 424 | $x = 1 foreach (@a); |
| 425 | #### |
| 426 | # 2 arguments in a 3 argument for |
| 427 | for (my $i = 0; $i < 2;) { |
| 428 | my $z = 1; |
| 429 | } |
| 430 | #### |
| 431 | # 3 argument for |
| 432 | for (my $i = 0; $i < 2; ++$i) { |
| 433 | my $z = 1; |
| 434 | } |
| 435 | #### |
| 436 | # 3 argument for again |
| 437 | for (my $i = 0; $i < 2; ++$i) { |
| 438 | my $z = 1; |
| 439 | } |
| 440 | #### |
| 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 | } |
| 448 | for (my $a; not +($1 || 2) ** 2;) { |
| 449 | die; |
| 450 | } |
| 451 | Something_to_put_the_loop_in_void_context(); |
| 452 | #### |
| 453 | # while/continue |
| 454 | my $i; |
| 455 | while ($i) { my $z = 1; } continue { $i = 99; } |
| 456 | #### |
| 457 | # foreach with my |
| 458 | foreach my $i (1, 2) { |
| 459 | my $z = 1; |
| 460 | } |
| 461 | #### |
| 462 | # OPTIONS -p |
| 463 | # foreach with my under -p |
| 464 | foreach my $i (1) { |
| 465 | die; |
| 466 | } |
| 467 | #### |
| 468 | # foreach |
| 469 | my $i; |
| 470 | foreach $i (1, 2) { |
| 471 | my $z = 1; |
| 472 | } |
| 473 | #### |
| 474 | # foreach, 2 mys |
| 475 | my $i; |
| 476 | foreach my $i (1, 2) { |
| 477 | my $z = 1; |
| 478 | } |
| 479 | #### |
| 480 | # foreach with our |
| 481 | foreach our $i (1, 2) { |
| 482 | my $z = 1; |
| 483 | } |
| 484 | #### |
| 485 | # foreach with my and our |
| 486 | my $i; |
| 487 | foreach our $i (1, 2) { |
| 488 | my $z = 1; |
| 489 | } |
| 490 | #### |
| 491 | # foreach with state |
| 492 | # CONTEXT use feature "state"; |
| 493 | foreach state $i (1, 2) { |
| 494 | state $z = 1; |
| 495 | } |
| 496 | #### |
| 497 | # reverse sort |
| 498 | my @x; |
| 499 | print reverse sort(@x); |
| 500 | #### |
| 501 | # sort with cmp |
| 502 | my @x; |
| 503 | print((sort {$b cmp $a} @x)); |
| 504 | #### |
| 505 | # reverse sort with block |
| 506 | my @x; |
| 507 | print((reverse sort {$b <=> $a} @x)); |
| 508 | #### |
| 509 | # foreach reverse |
| 510 | our @a; |
| 511 | print $_ foreach (reverse @a); |
| 512 | #### |
| 513 | # foreach reverse (not inplace) |
| 514 | our @a; |
| 515 | print $_ foreach (reverse 1, 2..5); |
| 516 | #### |
| 517 | # bug #38684 |
| 518 | our @ary; |
| 519 | @ary = split(' ', 'foo', 0); |
| 520 | #### |
| 521 | # Split to our array |
| 522 | our @array = split(//, 'foo', 0); |
| 523 | #### |
| 524 | # bug #40055 |
| 525 | do { () }; |
| 526 | #### |
| 527 | # bug #40055 |
| 528 | do { my $x = 1; $x }; |
| 529 | #### |
| 530 | # <20061012113037.GJ25805@c4.convolution.nl> |
| 531 | my $f = sub { |
| 532 | +{[]}; |
| 533 | } ; |
| 534 | #### |
| 535 | # bug #43010 |
| 536 | '!@$%'->(); |
| 537 | #### |
| 538 | # bug #43010 |
| 539 | ::(); |
| 540 | #### |
| 541 | # bug #43010 |
| 542 | '::::'->(); |
| 543 | #### |
| 544 | # bug #43010 |
| 545 | &::::; |
| 546 | #### |
| 547 | # [perl #77172] |
| 548 | package rt77172; |
| 549 | sub foo {} foo & & & foo; |
| 550 | >>>> |
| 551 | package rt77172; |
| 552 | foo(&{&} & foo()); |
| 553 | #### |
| 554 | # variables as method names |
| 555 | my $bar; |
| 556 | 'Foo'->$bar('orz'); |
| 557 | 'Foo'->$bar('orz') = 'a stranger stranger than before'; |
| 558 | #### |
| 559 | # constants as method names |
| 560 | 'Foo'->bar('orz'); |
| 561 | #### |
| 562 | # constants as method names without () |
| 563 | 'Foo'->bar; |
| 564 | #### |
| 565 | # [perl #47359] "indirect" method call notation |
| 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 | #### |
| 576 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" |
| 577 | # CONTEXT use feature ':5.10'; |
| 578 | # say |
| 579 | say 'foo'; |
| 580 | #### |
| 581 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" |
| 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" |
| 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" |
| 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" |
| 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" |
| 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" |
| 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 | #### |
| 666 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
| 667 | # CONTEXT use feature ':5.10'; |
| 668 | # state vars |
| 669 | state $x = 42; |
| 670 | #### |
| 671 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
| 672 | # CONTEXT use feature ':5.10'; |
| 673 | # state var assignment |
| 674 | { |
| 675 | my $y = (state $x = 42); |
| 676 | } |
| 677 | #### |
| 678 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
| 679 | # CONTEXT use feature ':5.10'; |
| 680 | # state vars in anonymous subroutines |
| 681 | $a = sub { |
| 682 | state $x; |
| 683 | return $x++; |
| 684 | } |
| 685 | ; |
| 686 | #### |
| 687 | # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' |
| 688 | # each @array; |
| 689 | each @ARGV; |
| 690 | each @$a; |
| 691 | #### |
| 692 | # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' |
| 693 | # keys @array; values @array |
| 694 | keys @$a if keys @ARGV; |
| 695 | values @ARGV if values @$a; |
| 696 | #### |
| 697 | # Anonymous arrays and hashes, and references to them |
| 698 | my $a = {}; |
| 699 | my $b = \{}; |
| 700 | my $c = []; |
| 701 | my $d = \[]; |
| 702 | #### |
| 703 | # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version" |
| 704 | # CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch'; |
| 705 | # implicit smartmatch in given/when |
| 706 | given ('foo') { |
| 707 | when ('bar') { continue; } |
| 708 | when ($_ ~~ 'quux') { continue; } |
| 709 | default { 0; } |
| 710 | } |
| 711 | #### |
| 712 | # conditions in elsifs (regression in change #33710 which fixed bug #37302) |
| 713 | if ($a) { x(); } |
| 714 | elsif ($b) { x(); } |
| 715 | elsif ($a and $b) { x(); } |
| 716 | elsif ($a or $b) { x(); } |
| 717 | else { x(); } |
| 718 | #### |
| 719 | # interpolation in regexps |
| 720 | my($y, $t); |
| 721 | /x${y}z$t/; |
| 722 | #### |
| 723 | # TODO new undocumented cpan-bug #33708 |
| 724 | # cpan-bug #33708 |
| 725 | %{$_ || {}} |
| 726 | #### |
| 727 | # TODO hash constants not yet fixed |
| 728 | # cpan-bug #33708 |
| 729 | use constant H => { "#" => 1 }; H->{"#"} |
| 730 | #### |
| 731 | # TODO optimized away 0 not yet fixed |
| 732 | # cpan-bug #33708 |
| 733 | foreach my $i (@_) { 0 } |
| 734 | #### |
| 735 | # tests with not, not optimized |
| 736 | my $c; |
| 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; |
| 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; |
| 754 | #### |
| 755 | # tests with not, optimized |
| 756 | my $c; |
| 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; |
| 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; |
| 772 | >>>> |
| 773 | my $c; |
| 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; |
| 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; |
| 789 | #### |
| 790 | # tests that should be constant folded |
| 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 | #### |
| 841 | # TODO constant deparsing has been backed out for 5.12 |
| 842 | # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads" |
| 843 | # tests that shouldn't be constant folded |
| 844 | # It might be fundamentally impossible to make this work on ithreads, in which |
| 845 | # case the TODO should become a SKIP |
| 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(); } |
| 853 | if (do { foo(); GLIPP }) { x(); } |
| 854 | if (do { ++$a; GLIPP }) { x(); } |
| 855 | #### |
| 856 | # TODO constant deparsing has been backed out for 5.12 |
| 857 | # tests for deparsing constants |
| 858 | warn PI; |
| 859 | #### |
| 860 | # TODO constant deparsing has been backed out for 5.12 |
| 861 | # tests for deparsing imported constants |
| 862 | warn O_TRUNC; |
| 863 | #### |
| 864 | # TODO constant deparsing has been backed out for 5.12 |
| 865 | # tests for deparsing re-exported constants |
| 866 | warn O_CREAT; |
| 867 | #### |
| 868 | # TODO constant deparsing has been backed out for 5.12 |
| 869 | # tests for deparsing imported constants that got deleted from the original namespace |
| 870 | warn O_APPEND; |
| 871 | #### |
| 872 | # TODO constant deparsing has been backed out for 5.12 |
| 873 | # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads" |
| 874 | # tests for deparsing constants which got turned into full typeglobs |
| 875 | # It might be fundamentally impossible to make this work on ithreads, in which |
| 876 | # case the TODO should become a SKIP |
| 877 | warn O_EXCL; |
| 878 | eval '@Fcntl::O_EXCL = qw/affe tiger/;'; |
| 879 | warn O_EXCL; |
| 880 | #### |
| 881 | # TODO constant deparsing has been backed out for 5.12 |
| 882 | # tests for deparsing of blessed constant with overloaded numification |
| 883 | warn OVERLOADED_NUMIFICATION; |
| 884 | #### |
| 885 | # strict |
| 886 | no strict; |
| 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'; |
| 895 | $x; |
| 896 | #### |
| 897 | # TODO Subsets of warnings could be encoded textually, rather than as bitflips. |
| 898 | # subsets of warnings |
| 899 | no warnings 'deprecated'; |
| 900 | my $x; |
| 901 | #### |
| 902 | # TODO Better test for CPAN #33708 - the deparsed code has different behaviour |
| 903 | # CPAN #33708 |
| 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 | } |
| 914 | #### |
| 915 | # no attribute list |
| 916 | my $pi = 4; |
| 917 | #### |
| 918 | # SKIP ?$] > 5.013006 && ":= is now a syntax error" |
| 919 | # := treated as an empty attribute list |
| 920 | no warnings; |
| 921 | my $pi := 4; |
| 922 | >>>> |
| 923 | no warnings; |
| 924 | my $pi = 4; |
| 925 | #### |
| 926 | # : = empty attribute list |
| 927 | my $pi : = 4; |
| 928 | >>>> |
| 929 | my $pi = 4; |
| 930 | #### |
| 931 | # in place sort |
| 932 | our @a; |
| 933 | my @b; |
| 934 | @a = sort @a; |
| 935 | @b = sort @b; |
| 936 | (); |
| 937 | #### |
| 938 | # in place reverse |
| 939 | our @a; |
| 940 | my @b; |
| 941 | @a = reverse @a; |
| 942 | @b = reverse @b; |
| 943 | (); |
| 944 | #### |
| 945 | # #71870 Use of uninitialized value in bitwise and B::Deparse |
| 946 | my($r, $s, @a); |
| 947 | @a = split(/foo/, $s, 0); |
| 948 | $r = qr/foo/; |
| 949 | @a = split(/$r/, $s, 0); |
| 950 | (); |
| 951 | #### |
| 952 | # package declaration before label |
| 953 | { |
| 954 | package Foo; |
| 955 | label: print 123; |
| 956 | } |
| 957 | #### |
| 958 | # shift optimisation |
| 959 | shift; |
| 960 | >>>> |
| 961 | shift(); |
| 962 | #### |
| 963 | # shift optimisation |
| 964 | shift @_; |
| 965 | #### |
| 966 | # shift optimisation |
| 967 | pop; |
| 968 | >>>> |
| 969 | pop(); |
| 970 | #### |
| 971 | # shift optimisation |
| 972 | pop @_; |
| 973 | #### |
| 974 | #[perl #20444] |
| 975 | "foo" =~ (1 ? /foo/ : /bar/); |
| 976 | "foo" =~ (1 ? y/foo// : /bar/); |
| 977 | "foo" =~ (1 ? y/foo//r : /bar/); |
| 978 | "foo" =~ (1 ? s/foo// : /bar/); |
| 979 | >>>> |
| 980 | 'foo' =~ ($_ =~ /foo/); |
| 981 | 'foo' =~ ($_ =~ tr/fo//); |
| 982 | 'foo' =~ ($_ =~ tr/fo//r); |
| 983 | 'foo' =~ ($_ =~ s/foo//); |
| 984 | #### |
| 985 | # The fix for [perl #20444] broke this. |
| 986 | 'foo' =~ do { () }; |
| 987 | #### |
| 988 | # [perl #81424] match against aelemfast_lex |
| 989 | my @s; |
| 990 | print /$s[1]/; |
| 991 | #### |
| 992 | # /$#a/ |
| 993 | print /$#main::a/; |
| 994 | #### |
| 995 | # [perl #91318] /regexp/applaud |
| 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; |
| 1001 | { |
| 1002 | use feature "unicode_strings"; |
| 1003 | print /a/d, s/b/c/d; |
| 1004 | } |
| 1005 | { |
| 1006 | use re "/u"; |
| 1007 | print /a/d, s/b/c/d; |
| 1008 | } |
| 1009 | { |
| 1010 | use 5.012; |
| 1011 | print /a/d, s/b/c/d; |
| 1012 | } |
| 1013 | >>>> |
| 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; |
| 1019 | { |
| 1020 | use feature 'unicode_strings'; |
| 1021 | print /a/d, s/b/c/d; |
| 1022 | } |
| 1023 | { |
| 1024 | BEGIN { $^H{'reflags'} = '0'; |
| 1025 | $^H{'reflags_charset'} = '2'; } |
| 1026 | print /a/d, s/b/c/d; |
| 1027 | } |
| 1028 | { |
| 1029 | no feature; |
| 1030 | use feature ':5.12'; |
| 1031 | print /a/d, s/b/c/d; |
| 1032 | } |
| 1033 | #### |
| 1034 | # [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns) |
| 1035 | s/foo/\(3);/eg; |
| 1036 | #### |
| 1037 | # y///r |
| 1038 | tr/a/b/r; |
| 1039 | #### |
| 1040 | # [perl #90898] |
| 1041 | <a,>; |
| 1042 | #### |
| 1043 | # [perl #91008] |
| 1044 | # CONTEXT no warnings 'experimental::autoderef'; |
| 1045 | each $@; |
| 1046 | keys $~; |
| 1047 | values $!; |
| 1048 | #### |
| 1049 | # readpipe with complex expression |
| 1050 | readpipe $a + $b; |
| 1051 | #### |
| 1052 | # aelemfast |
| 1053 | $b::a[0] = 1; |
| 1054 | #### |
| 1055 | # aelemfast for a lexical |
| 1056 | my @a; |
| 1057 | $a[0] = 1; |
| 1058 | #### |
| 1059 | # feature features without feature |
| 1060 | # CONTEXT no warnings 'experimental::smartmatch'; |
| 1061 | CORE::state $x; |
| 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__; |
| 1073 | () = CORE::fc $x; |
| 1074 | #### |
| 1075 | # feature features when feature has been disabled by use VERSION |
| 1076 | # CONTEXT no warnings 'experimental::smartmatch'; |
| 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 | >>>> |
| 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) |
| 1106 | # CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch'; |
| 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 | >>>> |
| 1123 | no feature; |
| 1124 | use feature ':default'; |
| 1125 | CORE::state $x; |
| 1126 | CORE::say $x; |
| 1127 | CORE::given ($x) { |
| 1128 | CORE::when (3) { |
| 1129 | continue; |
| 1130 | } |
| 1131 | CORE::default { |
| 1132 | CORE::break; |
| 1133 | } |
| 1134 | } |
| 1135 | CORE::evalbytes ''; |
| 1136 | () = CORE::__SUB__; |
| 1137 | #### |
| 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 | #### |
| 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 | >>>> |
| 1200 | use feature 'current_sub', 'evalbytes'; |
| 1201 | print $_; |
| 1202 | no feature; |
| 1203 | use feature ':default'; |
| 1204 | print $_; |
| 1205 | no feature; |
| 1206 | use feature ':5.12'; |
| 1207 | print $_; |
| 1208 | no feature 'unicode_strings'; |
| 1209 | print $_; |
| 1210 | #### |
| 1211 | # $#- $#+ $#{%} etc. |
| 1212 | my @x; |
| 1213 | @x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*}); |
| 1214 | @x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,}); |
| 1215 | @x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-); |
| 1216 | @x = ($#{;}, $#{:}); |
| 1217 | #### |
| 1218 | # ${#} interpolated |
| 1219 | # It's a known TODO that warnings are deparsed as bits, not textually. |
| 1220 | no warnings; |
| 1221 | () = "${#}a"; |
| 1222 | #### |
| 1223 | # [perl #86060] $( $| $) in regexps need braces |
| 1224 | /${(}/; |
| 1225 | /${|}/; |
| 1226 | /${)}/; |
| 1227 | /${(}${|}${)}/; |
| 1228 | #### |
| 1229 | # ()[...] |
| 1230 | my(@a) = ()[()]; |
| 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')); |
| 1239 | #### |
| 1240 | # substr assignment |
| 1241 | substr(my $a, 0, 0) = (foo(), bar()); |
| 1242 | $a++; |
| 1243 | #### |
| 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 |
| 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 | } |
| 1260 | BEGIN { $^H{q[']} = '('; } |
| 1261 | print $_; |
| 1262 | #### |
| 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 |
| 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 $_; |
| 1273 | #### |
| 1274 | # [perl #47361] do({}) and do +{} (variants of do-file) |
| 1275 | do({}); |
| 1276 | do +{}; |
| 1277 | sub foo::do {} |
| 1278 | package foo; |
| 1279 | CORE::do({}); |
| 1280 | CORE::do +{}; |
| 1281 | >>>> |
| 1282 | do({}); |
| 1283 | do({}); |
| 1284 | package foo; |
| 1285 | CORE::do({}); |
| 1286 | CORE::do({}); |
| 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; |
| 1295 | () = (goto 1) + 3; |
| 1296 | () = (require 'foo') + 3; |
| 1297 | () = (require foo) + 3; |
| 1298 | () = (CORE::dump 1) + 3; |
| 1299 | () = (last 1) + 3; |
| 1300 | () = (next 1) + 3; |
| 1301 | () = (redo 1) + 3; |
| 1302 | () = (-R $_) + 3; |
| 1303 | () = (-W $_) + 3; |
| 1304 | () = (-X $_) + 3; |
| 1305 | () = (-r $_) + 3; |
| 1306 | () = (-w $_) + 3; |
| 1307 | () = (-x $_) + 3; |
| 1308 | #### |
| 1309 | # [perl #97476] not() *does* follow the llafr |
| 1310 | $_ = ($a xor not +($1 || 2) ** 2); |
| 1311 | #### |
| 1312 | # Precedence conundrums with argument-less function calls |
| 1313 | () = (eof) + 1; |
| 1314 | () = (return) + 1; |
| 1315 | () = (return, 1); |
| 1316 | () = warn; |
| 1317 | () = warn() + 1; |
| 1318 | () = setpgrp() + 1; |
| 1319 | #### |
| 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 | #### |
| 1327 | # [perl #63558] open local(*FH) |
| 1328 | open local *FH; |
| 1329 | pipe local *FH, local *FH; |
| 1330 | #### |
| 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 | #### |
| 1342 | # "string"->[] ->{} |
| 1343 | no strict 'vars'; |
| 1344 | () = 'open'->[0]; #aelemfast |
| 1345 | () = '####'->[0]; |
| 1346 | () = '^A'->[0]; |
| 1347 | () = "\ca"->[0]; |
| 1348 | () = 'a::]b'->[0]; |
| 1349 | () = 'open'->[$_]; #aelem |
| 1350 | () = '####'->[$_]; |
| 1351 | () = '^A'->[$_]; |
| 1352 | () = "\ca"->[$_]; |
| 1353 | () = 'a::]b'->[$_]; |
| 1354 | () = 'open'->{0}; #helem |
| 1355 | () = '####'->{0}; |
| 1356 | () = '^A'->{0}; |
| 1357 | () = "\ca"->{0}; |
| 1358 | () = 'a::]b'->{0}; |
| 1359 | >>>> |
| 1360 | no strict 'vars'; |
| 1361 | () = $open[0]; |
| 1362 | () = '####'->[0]; |
| 1363 | () = '^A'->[0]; |
| 1364 | () = $^A[0]; |
| 1365 | () = 'a::]b'->[0]; |
| 1366 | () = $open[$_]; |
| 1367 | () = '####'->[$_]; |
| 1368 | () = '^A'->[$_]; |
| 1369 | () = $^A[$_]; |
| 1370 | () = 'a::]b'->[$_]; |
| 1371 | () = $open{'0'}; |
| 1372 | () = '####'->{'0'}; |
| 1373 | () = '^A'->{'0'}; |
| 1374 | () = $^A{'0'}; |
| 1375 | () = 'a::]b'->{'0'}; |
| 1376 | #### |
| 1377 | # [perl #74740] -(f()) vs -f() |
| 1378 | $_ = -(f()); |
| 1379 | #### |
| 1380 | # require <binop> |
| 1381 | require 'a' . $1; |
| 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 | } |
| 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'; |
| 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; |
| 1526 | #### |
| 1527 | # @_ with padrange |
| 1528 | my($a, $b, $c) = @_; |
| 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'; |
| 1534 | no warnings "experimental::lexical_subs"; |
| 1535 | my sub f {} |
| 1536 | print f(); |
| 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(); |
| 1545 | #### |
| 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 | #### |
| 1565 | # Elements of %# should not be confused with $#{ array } |
| 1566 | () = ${#}{'foo'}; |
| 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; |
| 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]; |
| 1586 | #### |
| 1587 | # 'm' must be preserved in m?? |
| 1588 | m??; |
| 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); |
| 1598 | #### |
| 1599 | # subs synonymous with keywords |
| 1600 | main::our(); |
| 1601 | main::pop(); |
| 1602 | state(); |
| 1603 | use feature 'state'; |
| 1604 | main::state(); |