dist/B-Deparse/t/deparse.t

   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 = 18; # 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
  22 $/ = "\n####\n";
  23 while (<DATA>) {
  24     chomp;
  25     $tests ++;
  26     # This code is pinched from the t/lib/common.pl for TODO.
  27     # It's not clear how to avoid duplication
  28     my %meta = (context => '');
  29     foreach my $what (qw(skip todo context)) {
  30         s/^#\s*\U$what\E\s*(.*)\n//m and $meta{$what} = $1;
  31         # If the SKIP reason starts ? then it's taken as a code snippet to
  32         # evaluate. This provides the flexibility to have conditional SKIPs
  33         if ($meta{$what} && $meta{$what} =~ s/^\?//) {
  34             my $temp = eval $meta{$what};
  35             if ($@) {
  36                 die "# In \U$what\E code reason:\n# $meta{$what}\n$@";
  37             }
  38             $meta{$what} = $temp;
  39         }
  40     }
  41
  42     s/^\s*#\s*(.*)$//mg;
  43     my $desc = $1;
  44     die "Missing name in test $_" unless defined $desc;
  45
  46     if ($meta{skip}) {
  47         # Like this to avoid needing a label SKIP:
  48         Test::More->builder->skip($meta{skip});
  49         next;
  50     }
  51
  52     my ($input, $expected);
  53     if (/(.*)\n>>>>\n(.*)/s) {
  54         ($input, $expected) = ($1, $2);
  55     }
  56     else {
  57         ($input, $expected) = ($_, $_);
  58     }
  59
  60     my $coderef = eval "$meta{context};\n" . <<'EOC' . "sub {$input}";
  61 # Tell B::Deparse about our ambient pragmas
  62 my ($hint_bits, $warning_bits, $hinthash);
  63 BEGIN {
  64     ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H);
  65 }
  66 $deparse->ambient_pragmas (
  67     hint_bits    => $hint_bits,
  68     warning_bits => $warning_bits,
  69     '%^H'        => $hinthash,
  70 );
  71 EOC
  72
  73     if ($@) {
  74         is($@, "", "compilation of $desc");
  75     }
  76     else {
  77         my $deparsed = $deparse->coderef2text( $coderef );
  78         my $regex = $expected;
  79         $regex =~ s/(\S+)/\Q$1/g;
  80         $regex =~ s/\s+/\\s+/g;
  81         $regex = '^\{\s*' . $regex . '\s*\}$';
  82
  83         local $::TODO = $meta{todo};
  84         like($deparsed, qr/$regex/, $desc);
  85     }
  86 }
  87
  88 use constant 'c', 'stuff';
  89 is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff',
  90    'the subroutine generated by use constant deparses');
  91
  92 my $a = 0;
  93 is($deparse->coderef2text(sub{(-1) ** $a }), "{\n    (-1) ** \$a;\n}",
  94    'anon sub capturing an external lexical');
  95
  96 use constant cr => ['hello'];
  97 my $string = "sub " . $deparse->coderef2text(\&cr);
  98 my $val = (eval $string)->() or diag $string;
  99 is(ref($val), 'ARRAY', 'constant array references deparse');
 100 is($val->[0], 'hello', 'and return the correct value');
 101
 102 my $path = join " ", map { qq["-I$_"] } @INC;
 103
 104 $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 2>&1`;
 105 $a =~ s/-e syntax OK\n//g;
 106 $a =~ s/.*possible typo.*\n//;     # Remove warning line
 107 $a =~ s/.*-i used with no filenames.*\n//;      # Remove warning line
 108 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
 109 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
 110 $b = <<'EOF';
 111 BEGIN { $^I = ".bak"; }
 112 BEGIN { $^W = 1; }
 113 BEGIN { $/ = "\n"; $\ = "\n"; }
 114 LINE: while (defined($_ = <ARGV>)) {
 115     chomp $_;
 116     our(@F) = split(' ', $_, 0);
 117     '???';
 118 }
 119 EOF
 120 is($a, $b,
 121    'command line flags deparse as BEGIN blocks setting control variables');
 122
 123 $a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`;
 124 $a =~ s/-e syntax OK\n//g;
 125 is($a, "use constant ('PI', 4);\n",
 126    "Proxy Constant Subroutines must not show up as (incorrect) prototypes");
 127
 128 #Re: perlbug #35857, patch #24505
 129 #handle warnings::register-ed packages properly.
 130 package B::Deparse::Wrapper;
 131 use strict;
 132 use warnings;
 133 use warnings::register;
 134 sub getcode {
 135    my $deparser = B::Deparse->new();
 136    return $deparser->coderef2text(shift);
 137 }
 138
 139 package Moo;
 140 use overload '0+' => sub { 42 };
 141
 142 package main;
 143 use strict;
 144 use warnings;
 145 use constant GLIPP => 'glipp';
 146 use constant PI => 4;
 147 use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo');
 148 use Fcntl qw/O_TRUNC O_APPEND O_EXCL/;
 149 BEGIN { delete $::Fcntl::{O_APPEND}; }
 150 use POSIX qw/O_CREAT/;
 151 sub test {
 152    my $val = shift;
 153    my $res = B::Deparse::Wrapper::getcode($val);
 154    like($res, qr/use warnings/,
 155         '[perl #35857] [PATCH] B::Deparse doesnt handle warnings register properly');
 156 }
 157 my ($q,$p);
 158 my $x=sub { ++$q,++$p };
 159 test($x);
 160 eval <<EOFCODE and test($x);
 161    package bar;
 162    use strict;
 163    use warnings;
 164    use warnings::register;
 165    package main;
 166    1
 167 EOFCODE
 168
 169 # Exotic sub declarations
 170 $a = `$^X $path "-MO=Deparse" -e "sub ::::{}sub ::::::{}" 2>&1`;
 171 $a =~ s/-e syntax OK\n//g;
 172 is($a, <<'EOCODG', "sub :::: and sub ::::::");
 173 sub :::: {
 174
 175 }
 176 sub :::::: {
 177
 178 }
 179 EOCODG
 180
 181 # [perl #33752]
 182 {
 183   my $code = <<"EOCODE";
 184 {
 185     our \$\x{1e1f}\x{14d}\x{14d};
 186 }
 187 EOCODE
 188   my $deparsed
 189    = $deparse->coderef2text(eval "sub { our \$\x{1e1f}\x{14d}\x{14d} }" );
 190   s/$ \n//x for $deparsed, $code;
 191   is $deparsed, $code, 'our $funny_Unicode_chars';
 192 }
 193
 194 # [perl #62500]
 195 $a =
 196   `$^X $path "-MO=Deparse" -e "BEGIN{*CORE::GLOBAL::require=sub{1}}" 2>&1`;
 197 $a =~ s/-e syntax OK\n//g;
 198 is($a, <<'EOCODF', "CORE::GLOBAL::require override causing panick");
 199 sub BEGIN {
 200     *CORE::GLOBAL::require = sub {
 201         1;
 202     }
 203     ;
 204 }
 205 EOCODF
 206
 207 # [perl #91384]
 208 $a =
 209   `$^X $path "-MO=Deparse" -e "BEGIN{*Acme::Acme:: = *Acme::}" 2>&1`;
 210 like($a, qr/-e syntax OK/,
 211     "Deparse does not hang when traversing stash circularities");
 212
 213 # [perl #93990]
 214 @* = ();
 215 is($deparse->coderef2text(sub{ print "@{*}" }),
 216 q<{
 217     print "@{*}";
 218 }>, 'curly around to interpolate "@{*}"');
 219 is($deparse->coderef2text(sub{ print "@{-}" }),
 220 q<{
 221     print "@-";
 222 }>, 'no need to curly around to interpolate "@-"');
 223
 224 # Strict hints in %^H are mercilessly suppressed
 225 $a =
 226   `$^X $path "-MO=Deparse" -e "use strict; print;" 2>&1`;
 227 unlike($a, qr/BEGIN/,
 228     "Deparse does not emit strict hh hints");
 229
 230 # ambient_pragmas should not mess with strict settings.
 231 SKIP: {
 232     skip "requires 5.11", 1 unless $] >= 5.011;
 233     eval q`
 234         BEGIN {
 235             # Clear out all hints
 236             %^H = ();
 237             $^H = 0;
 238             new B::Deparse -> ambient_pragmas(strict => 'all');
 239         }
 240         use 5.011;  # should enable strict
 241         ok !eval '$do_noT_create_a_variable_with_this_name = 1',
 242           'ambient_pragmas do not mess with compiling scope';
 243    `;
 244 }
 245
 246 # multiple statements on format lines
 247 $a = `$^X $path "-MO=Deparse" -e "format =" -e "\@" -e "x();z()" -e. 2>&1`;
 248 $a =~ s/-e syntax OK\n//g;
 249 is($a, <<'EOCODH', 'multiple statements on format lines');
 250 format STDOUT =
 251 @
 252 x(); z()
 253 .
 254 EOCODH
 255
 256
 257 done_testing($tests);
 258
 259 __DATA__
 260 # A constant
 261 1;
 262 ####
 263 # Constants in a block
 264 {
 265     no warnings;
 266     '???';
 267     2;
 268 }
 269 ####
 270 # Lexical and simple arithmetic
 271 my $test;
 272 ++$test and $test /= 2;
 273 >>>>
 274 my $test;
 275 $test /= 2 if ++$test;
 276 ####
 277 # list x
 278 -((1, 2) x 2);
 279 ####
 280 # lvalue sub
 281 {
 282     my $test = sub : lvalue {
 283         my $x;
 284     }
 285     ;
 286 }
 287 ####
 288 # method
 289 {
 290     my $test = sub : method {
 291         my $x;
 292     }
 293     ;
 294 }
 295 ####
 296 # block with continue
 297 {
 298     234;
 299 }
 300 continue {
 301     123;
 302 }
 303 ####
 304 # lexical and package scalars
 305 my $x;
 306 print $main::x;
 307 ####
 308 # lexical and package arrays
 309 my @x;
 310 print $main::x[1];
 311 ####
 312 # lexical and package hashes
 313 my %x;
 314 $x{warn()};
 315 ####
 316 # <>
 317 my $foo;
 318 $_ .= <ARGV> . <$foo>;
 319 ####
 320 # \x{}
 321 my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ";
 322 ####
 323 # s///e
 324 s/x/'y';/e;
 325 s/x/$a;/e;
 326 s/x/complex_expression();/e;
 327 ####
 328 # block
 329 { my $x; }
 330 ####
 331 # while 1
 332 while (1) { my $k; }
 333 ####
 334 # trailing for
 335 my ($x,@a);
 336 $x=1 for @a;
 337 >>>>
 338 my($x, @a);
 339 $x = 1 foreach (@a);
 340 ####
 341 # 2 arguments in a 3 argument for
 342 for (my $i = 0; $i < 2;) {
 343     my $z = 1;
 344 }
 345 ####
 346 # 3 argument for
 347 for (my $i = 0; $i < 2; ++$i) {
 348     my $z = 1;
 349 }
 350 ####
 351 # 3 argument for again
 352 for (my $i = 0; $i < 2; ++$i) {
 353     my $z = 1;
 354 }
 355 ####
 356 # while/continue
 357 my $i;
 358 while ($i) { my $z = 1; } continue { $i = 99; }
 359 ####
 360 # foreach with my
 361 foreach my $i (1, 2) {
 362     my $z = 1;
 363 }
 364 ####
 365 # foreach
 366 my $i;
 367 foreach $i (1, 2) {
 368     my $z = 1;
 369 }
 370 ####
 371 # foreach, 2 mys
 372 my $i;
 373 foreach my $i (1, 2) {
 374     my $z = 1;
 375 }
 376 ####
 377 # foreach
 378 foreach my $i (1, 2) {
 379     my $z = 1;
 380 }
 381 ####
 382 # foreach with our
 383 foreach our $i (1, 2) {
 384     my $z = 1;
 385 }
 386 ####
 387 # foreach with my and our
 388 my $i;
 389 foreach our $i (1, 2) {
 390     my $z = 1;
 391 }
 392 ####
 393 # reverse sort
 394 my @x;
 395 print reverse sort(@x);
 396 ####
 397 # sort with cmp
 398 my @x;
 399 print((sort {$b cmp $a} @x));
 400 ####
 401 # reverse sort with block
 402 my @x;
 403 print((reverse sort {$b <=> $a} @x));
 404 ####
 405 # foreach reverse
 406 our @a;
 407 print $_ foreach (reverse @a);
 408 ####
 409 # foreach reverse (not inplace)
 410 our @a;
 411 print $_ foreach (reverse 1, 2..5);
 412 ####
 413 # bug #38684
 414 our @ary;
 415 @ary = split(' ', 'foo', 0);
 416 ####
 417 # bug #40055
 418 do { () };
 419 ####
 420 # bug #40055
 421 do { my $x = 1; $x };
 422 ####
 423 # <20061012113037.GJ25805@c4.convolution.nl>
 424 my $f = sub {
 425     +{[]};
 426 } ;
 427 ####
 428 # bug #43010
 429 '!@$%'->();
 430 ####
 431 # bug #43010
 432 ::();
 433 ####
 434 # bug #43010
 435 '::::'->();
 436 ####
 437 # bug #43010
 438 &::::;
 439 ####
 440 # [perl #77172]
 441 package rt77172;
 442 sub foo {} foo & & & foo;
 443 >>>>
 444 package rt77172;
 445 foo(&{&} & foo());
 446 ####
 447 # variables as method names
 448 my $bar;
 449 'Foo'->$bar('orz');
 450 'Foo'->$bar('orz') = 'a stranger stranger than before';
 451 ####
 452 # constants as method names
 453 'Foo'->bar('orz');
 454 ####
 455 # constants as method names without ()
 456 'Foo'->bar;
 457 ####
 458 # [perl #47359] "indirect" method call notation
 459 our @bar;
 460 foo{@bar}+1,->foo;
 461 (foo{@bar}+1),foo();
 462 foo{@bar}1 xor foo();
 463 >>>>
 464 our @bar;
 465 (foo { @bar } 1)->foo;
 466 (foo { @bar } 1), foo();
 467 foo { @bar } 1 xor foo();
 468 ####
 469 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 470 # CONTEXT use feature ':5.10';
 471 # say
 472 say 'foo';
 473 ####
 474 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 475 # CONTEXT use 5.10.0;
 476 # say in the context of use 5.10.0
 477 say 'foo';
 478 ####
 479 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 480 # say with use 5.10.0
 481 use 5.10.0;
 482 say 'foo';
 483 >>>>
 484 no feature;
 485 use feature ':5.10';
 486 say 'foo';
 487 ####
 488 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 489 # say with use feature ':5.10';
 490 use feature ':5.10';
 491 say 'foo';
 492 >>>>
 493 use feature 'say', 'state', 'switch';
 494 say 'foo';
 495 ####
 496 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 497 # CONTEXT use feature ':5.10';
 498 # say with use 5.10.0 in the context of use feature
 499 use 5.10.0;
 500 say 'foo';
 501 >>>>
 502 no feature;
 503 use feature ':5.10';
 504 say 'foo';
 505 ####
 506 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 507 # CONTEXT use 5.10.0;
 508 # say with use feature ':5.10' in the context of use 5.10.0
 509 use feature ':5.10';
 510 say 'foo';
 511 >>>>
 512 say 'foo';
 513 ####
 514 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
 515 # CONTEXT use feature ':5.15';
 516 # __SUB__
 517 __SUB__;
 518 ####
 519 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
 520 # CONTEXT use 5.15.0;
 521 # __SUB__ in the context of use 5.15.0
 522 __SUB__;
 523 ####
 524 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
 525 # __SUB__ with use 5.15.0
 526 use 5.15.0;
 527 __SUB__;
 528 >>>>
 529 no feature;
 530 use feature ':5.16';
 531 __SUB__;
 532 ####
 533 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
 534 # __SUB__ with use feature ':5.15';
 535 use feature ':5.15';
 536 __SUB__;
 537 >>>>
 538 use feature 'current_sub', 'evalbytes', 'fc', 'say', 'state', 'switch', 'unicode_strings', 'unicode_eval';
 539 __SUB__;
 540 ####
 541 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
 542 # CONTEXT use feature ':5.15';
 543 # __SUB__ with use 5.15.0 in the context of use feature
 544 use 5.15.0;
 545 __SUB__;
 546 >>>>
 547 no feature;
 548 use feature ':5.16';
 549 __SUB__;
 550 ####
 551 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
 552 # CONTEXT use 5.15.0;
 553 # __SUB__ with use feature ':5.15' in the context of use 5.15.0
 554 use feature ':5.15';
 555 __SUB__;
 556 >>>>
 557 __SUB__;
 558 ####
 559 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 560 # CONTEXT use feature ':5.10';
 561 # state vars
 562 state $x = 42;
 563 ####
 564 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 565 # CONTEXT use feature ':5.10';
 566 # state var assignment
 567 {
 568     my $y = (state $x = 42);
 569 }
 570 ####
 571 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 572 # CONTEXT use feature ':5.10';
 573 # state vars in anonymous subroutines
 574 $a = sub {
 575     state $x;
 576     return $x++;
 577 }
 578 ;
 579 ####
 580 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
 581 # each @array;
 582 each @ARGV;
 583 each @$a;
 584 ####
 585 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
 586 # keys @array; values @array
 587 keys @$a if keys @ARGV;
 588 values @ARGV if values @$a;
 589 ####
 590 # Anonymous arrays and hashes, and references to them
 591 my $a = {};
 592 my $b = \{};
 593 my $c = [];
 594 my $d = \[];
 595 ####
 596 # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
 597 # CONTEXT use feature ':5.10';
 598 # implicit smartmatch in given/when
 599 given ('foo') {
 600     when ('bar') { continue; }
 601     when ($_ ~~ 'quux') { continue; }
 602     default { 0; }
 603 }
 604 ####
 605 # conditions in elsifs (regression in change #33710 which fixed bug #37302)
 606 if ($a) { x(); }
 607 elsif ($b) { x(); }
 608 elsif ($a and $b) { x(); }
 609 elsif ($a or $b) { x(); }
 610 else { x(); }
 611 ####
 612 # interpolation in regexps
 613 my($y, $t);
 614 /x${y}z$t/;
 615 ####
 616 # TODO new undocumented cpan-bug #33708
 617 # cpan-bug #33708
 618 %{$_ || {}}
 619 ####
 620 # TODO hash constants not yet fixed
 621 # cpan-bug #33708
 622 use constant H => { "#" => 1 }; H->{"#"}
 623 ####
 624 # TODO optimized away 0 not yet fixed
 625 # cpan-bug #33708
 626 foreach my $i (@_) { 0 }
 627 ####
 628 # tests with not, not optimized
 629 my $c;
 630 x() unless $a;
 631 x() if not $a and $b;
 632 x() if $a and not $b;
 633 x() unless not $a and $b;
 634 x() unless $a and not $b;
 635 x() if not $a or $b;
 636 x() if $a or not $b;
 637 x() unless not $a or $b;
 638 x() unless $a or not $b;
 639 x() if $a and not $b and $c;
 640 x() if not $a and $b and not $c;
 641 x() unless $a and not $b and $c;
 642 x() unless not $a and $b and not $c;
 643 x() if $a or not $b or $c;
 644 x() if not $a or $b or not $c;
 645 x() unless $a or not $b or $c;
 646 x() unless not $a or $b or not $c;
 647 ####
 648 # tests with not, optimized
 649 my $c;
 650 x() if not $a;
 651 x() unless not $a;
 652 x() if not $a and not $b;
 653 x() unless not $a and not $b;
 654 x() if not $a or not $b;
 655 x() unless not $a or not $b;
 656 x() if not $a and not $b and $c;
 657 x() unless not $a and not $b and $c;
 658 x() if not $a or not $b or $c;
 659 x() unless not $a or not $b or $c;
 660 x() if not $a and not $b and not $c;
 661 x() unless not $a and not $b and not $c;
 662 x() if not $a or not $b or not $c;
 663 x() unless not $a or not $b or not $c;
 664 x() unless not $a or not $b or not $c;
 665 >>>>
 666 my $c;
 667 x() unless $a;
 668 x() if $a;
 669 x() unless $a or $b;
 670 x() if $a or $b;
 671 x() unless $a and $b;
 672 x() if $a and $b;
 673 x() if not $a || $b and $c;
 674 x() unless not $a || $b and $c;
 675 x() if not $a && $b or $c;
 676 x() unless not $a && $b or $c;
 677 x() unless $a or $b or $c;
 678 x() if $a or $b or $c;
 679 x() unless $a and $b and $c;
 680 x() if $a and $b and $c;
 681 x() unless not $a && $b && $c;
 682 ####
 683 # tests that should be constant folded
 684 x() if 1;
 685 x() if GLIPP;
 686 x() if !GLIPP;
 687 x() if GLIPP && GLIPP;
 688 x() if !GLIPP || GLIPP;
 689 x() if do { GLIPP };
 690 x() if do { no warnings 'void'; 5; GLIPP };
 691 x() if do { !GLIPP };
 692 if (GLIPP) { x() } else { z() }
 693 if (!GLIPP) { x() } else { z() }
 694 if (GLIPP) { x() } elsif (GLIPP) { z() }
 695 if (!GLIPP) { x() } elsif (GLIPP) { z() }
 696 if (GLIPP) { x() } elsif (!GLIPP) { z() }
 697 if (!GLIPP) { x() } elsif (!GLIPP) { z() }
 698 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
 699 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
 700 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
 701 >>>>
 702 x();
 703 x();
 704 '???';
 705 x();
 706 x();
 707 x();
 708 x();
 709 do {
 710     '???'
 711 };
 712 do {
 713     x()
 714 };
 715 do {
 716     z()
 717 };
 718 do {
 719     x()
 720 };
 721 do {
 722     z()
 723 };
 724 do {
 725     x()
 726 };
 727 '???';
 728 do {
 729     t()
 730 };
 731 '???';
 732 !1;
 733 ####
 734 # TODO constant deparsing has been backed out for 5.12
 735 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
 736 # tests that shouldn't be constant folded
 737 # It might be fundamentally impossible to make this work on ithreads, in which
 738 # case the TODO should become a SKIP
 739 x() if $a;
 740 if ($a == 1) { x() } elsif ($b == 2) { z() }
 741 if (do { foo(); GLIPP }) { x() }
 742 if (do { $a++; GLIPP }) { x() }
 743 >>>>
 744 x() if $a;
 745 if ($a == 1) { x(); } elsif ($b == 2) { z(); }
 746 if (do { foo(); GLIPP }) { x(); }
 747 if (do { ++$a; GLIPP }) { x(); }
 748 ####
 749 # TODO constant deparsing has been backed out for 5.12
 750 # tests for deparsing constants
 751 warn PI;
 752 ####
 753 # TODO constant deparsing has been backed out for 5.12
 754 # tests for deparsing imported constants
 755 warn O_TRUNC;
 756 ####
 757 # TODO constant deparsing has been backed out for 5.12
 758 # tests for deparsing re-exported constants
 759 warn O_CREAT;
 760 ####
 761 # TODO constant deparsing has been backed out for 5.12
 762 # tests for deparsing imported constants that got deleted from the original namespace
 763 warn O_APPEND;
 764 ####
 765 # TODO constant deparsing has been backed out for 5.12
 766 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
 767 # tests for deparsing constants which got turned into full typeglobs
 768 # It might be fundamentally impossible to make this work on ithreads, in which
 769 # case the TODO should become a SKIP
 770 warn O_EXCL;
 771 eval '@Fcntl::O_EXCL = qw/affe tiger/;';
 772 warn O_EXCL;
 773 ####
 774 # TODO constant deparsing has been backed out for 5.12
 775 # tests for deparsing of blessed constant with overloaded numification
 776 warn OVERLOADED_NUMIFICATION;
 777 ####
 778 # strict
 779 no strict;
 780 print $x;
 781 use strict 'vars';
 782 print $main::x;
 783 use strict 'subs';
 784 print $main::x;
 785 use strict 'refs';
 786 print $main::x;
 787 no strict 'vars';
 788 $x;
 789 ####
 790 # TODO Subsets of warnings could be encoded textually, rather than as bitflips.
 791 # subsets of warnings
 792 no warnings 'deprecated';
 793 my $x;
 794 ####
 795 # TODO Better test for CPAN #33708 - the deparsed code has different behaviour
 796 # CPAN #33708
 797 use strict;
 798 no warnings;
 799
 800 foreach (0..3) {
 801     my $x = 2;
 802     {
 803         my $x if 0;
 804         print ++$x, "\n";
 805     }
 806 }
 807 ####
 808 # no attribute list
 809 my $pi = 4;
 810 ####
 811 # SKIP ?$] > 5.013006 && ":= is now a syntax error"
 812 # := treated as an empty attribute list
 813 no warnings;
 814 my $pi := 4;
 815 >>>>
 816 no warnings;
 817 my $pi = 4;
 818 ####
 819 # : = empty attribute list
 820 my $pi : = 4;
 821 >>>>
 822 my $pi = 4;
 823 ####
 824 # in place sort
 825 our @a;
 826 my @b;
 827 @a = sort @a;
 828 @b = sort @b;
 829 ();
 830 ####
 831 # in place reverse
 832 our @a;
 833 my @b;
 834 @a = reverse @a;
 835 @b = reverse @b;
 836 ();
 837 ####
 838 # #71870 Use of uninitialized value in bitwise and B::Deparse
 839 my($r, $s, @a);
 840 @a = split(/foo/, $s, 0);
 841 $r = qr/foo/;
 842 @a = split(/$r/, $s, 0);
 843 ();
 844 ####
 845 # package declaration before label
 846 {
 847     package Foo;
 848     label: print 123;
 849 }
 850 ####
 851 # shift optimisation
 852 shift;
 853 >>>>
 854 shift();
 855 ####
 856 # shift optimisation
 857 shift @_;
 858 ####
 859 # shift optimisation
 860 pop;
 861 >>>>
 862 pop();
 863 ####
 864 # shift optimisation
 865 pop @_;
 866 ####
 867 #[perl #20444]
 868 "foo" =~ (1 ? /foo/ : /bar/);
 869 "foo" =~ (1 ? y/foo// : /bar/);
 870 "foo" =~ (1 ? y/foo//r : /bar/);
 871 "foo" =~ (1 ? s/foo// : /bar/);
 872 >>>>
 873 'foo' =~ ($_ =~ /foo/);
 874 'foo' =~ ($_ =~ tr/fo//);
 875 'foo' =~ ($_ =~ tr/fo//r);
 876 'foo' =~ ($_ =~ s/foo//);
 877 ####
 878 # The fix for [perl #20444] broke this.
 879 'foo' =~ do { () };
 880 ####
 881 # [perl #81424] match against aelemfast_lex
 882 my @s;
 883 print /$s[1]/;
 884 ####
 885 # /$#a/
 886 print /$#main::a/;
 887 ####
 888 # [perl #91318] /regexp/applaud
 889 print /a/a, s/b/c/a;
 890 print /a/aa, s/b/c/aa;
 891 print /a/p, s/b/c/p;
 892 print /a/l, s/b/c/l;
 893 print /a/u, s/b/c/u;
 894 {
 895     use feature "unicode_strings";
 896     print /a/d, s/b/c/d;
 897 }
 898 {
 899     use re "/u";
 900     print /a/d, s/b/c/d;
 901 }
 902 {
 903     use 5.012;
 904     print /a/d, s/b/c/d;
 905 }
 906 >>>>
 907 print /a/a, s/b/c/a;
 908 print /a/aa, s/b/c/aa;
 909 print /a/p, s/b/c/p;
 910 print /a/l, s/b/c/l;
 911 print /a/u, s/b/c/u;
 912 {
 913     use feature 'unicode_strings';
 914     print /a/d, s/b/c/d;
 915 }
 916 {
 917     BEGIN { $^H{'reflags'}         = '0';
 918             $^H{'reflags_charset'} = '2'; }
 919     print /a/d, s/b/c/d;
 920 }
 921 {
 922     no feature;
 923     use feature ':5.12';
 924     print /a/d, s/b/c/d;
 925 }
 926 ####
 927 # Test @threadsv_names under 5005threads
 928 foreach $' (1, 2) {
 929     sleep $';
 930 }
 931 ####
 932 # y///r
 933 tr/a/b/r;
 934 ####
 935 # y/uni/code/
 936 tr/\x{345}/\x{370}/;
 937 ####
 938 # [perl #90898]
 939 <a,>;
 940 ####
 941 # [perl #91008]
 942 each $@;
 943 keys $~;
 944 values $!;
 945 ####
 946 # readpipe with complex expression
 947 readpipe $a + $b;
 948 ####
 949 # aelemfast
 950 $b::a[0] = 1;
 951 ####
 952 # aelemfast for a lexical
 953 my @a;
 954 $a[0] = 1;
 955 ####
 956 # feature features without feature
 957 CORE::state $x;
 958 CORE::say $x;
 959 CORE::given ($x) {
 960     CORE::when (3) {
 961         continue;
 962     }
 963     CORE::default {
 964         CORE::break;
 965     }
 966 }
 967 CORE::evalbytes '';
 968 () = CORE::__SUB__;
 969 () = CORE::fc $x;
 970 ####
 971 # feature features when feature has been disabled by use VERSION
 972 use feature (sprintf(":%vd", $^V));
 973 use 1;
 974 CORE::state $x;
 975 CORE::say $x;
 976 CORE::given ($x) {
 977     CORE::when (3) {
 978         continue;
 979     }
 980     CORE::default {
 981         CORE::break;
 982     }
 983 }
 984 CORE::evalbytes '';
 985 () = CORE::__SUB__;
 986 >>>>
 987 CORE::state $x;
 988 CORE::say $x;
 989 CORE::given ($x) {
 990     CORE::when (3) {
 991         continue;
 992     }
 993     CORE::default {
 994         CORE::break;
 995     }
 996 }
 997 CORE::evalbytes '';
 998 () = CORE::__SUB__;
 999 ####
1000 # (the above test with CONTEXT, and the output is equivalent but different)
1001 # CONTEXT use feature ':5.10';
1002 # feature features when feature has been disabled by use VERSION
1003 use feature (sprintf(":%vd", $^V));
1004 use 1;
1005 CORE::state $x;
1006 CORE::say $x;
1007 CORE::given ($x) {
1008     CORE::when (3) {
1009         continue;
1010     }
1011     CORE::default {
1012         CORE::break;
1013     }
1014 }
1015 CORE::evalbytes '';
1016 () = CORE::__SUB__;
1017 >>>>
1018 no feature;
1019 use feature ':default';
1020 CORE::state $x;
1021 CORE::say $x;
1022 CORE::given ($x) {
1023     CORE::when (3) {
1024         continue;
1025     }
1026     CORE::default {
1027         CORE::break;
1028     }
1029 }
1030 CORE::evalbytes '';
1031 () = CORE::__SUB__;
1032 ####
1033 # Feature hints
1034 use feature 'current_sub', 'evalbytes';
1035 print;
1036 use 1;
1037 print;
1038 use 5.014;
1039 print;
1040 no feature 'unicode_strings';
1041 print;
1042 >>>>
1043 use feature 'current_sub', 'evalbytes';
1044 print $_;
1045 no feature;
1046 use feature ':default';
1047 print $_;
1048 no feature;
1049 use feature ':5.12';
1050 print $_;
1051 no feature 'unicode_strings';
1052 print $_;
1053 ####
1054 # $#- $#+ $#{%} etc.
1055 my @x;
1056 @x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*});
1057 @x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,});
1058 @x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-);
1059 @x = ($#{;}, $#{:});
1060 ####
1061 # ${#} interpolated (the first line magically disables the warning)
1062 () = *#;
1063 () = "${#}a";
1064 ####
1065 # [perl #86060] $( $| $) in regexps need braces
1066 /${(}/;
1067 /${|}/;
1068 /${)}/;
1069 /${(}${|}${)}/;
1070 ####
1071 # ()[...]
1072 my(@a) = ()[()];
1073 ####
1074 # sort(foo(bar))
1075 # sort(foo(bar)) is interpreted as sort &foo(bar)
1076 # sort foo(bar) is interpreted as sort foo bar
1077 # parentheses are not optional in this case
1078 print sort(foo('bar'));
1079 >>>>
1080 print sort(foo('bar'));
1081 ####
1082 # substr assignment
1083 substr(my $a, 0, 0) = (foo(), bar());
1084 $a++;
1085 ####
1086 # This following line works around an unfixed bug that we are not trying to
1087 # test for here:
1088 # CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
1089 # hint hash
1090 BEGIN { $^H{'foo'} = undef; }
1091 {
1092  BEGIN { $^H{'bar'} = undef; }
1093  {
1094   BEGIN { $^H{'baz'} = undef; }
1095   {
1096    print $_;
1097   }
1098   print $_;
1099  }
1100  print $_;
1101 }
1102 BEGIN { $^H{q[']} = '('; }
1103 print $_;
1104 ####
1105 # This following line works around an unfixed bug that we are not trying to
1106 # test for here:
1107 # CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
1108 # hint hash changes that serialise the same way with sort %hh
1109 BEGIN { $^H{'a'} = 'b'; }
1110 {
1111  BEGIN { $^H{'b'} = 'a'; delete $^H{'a'}; }
1112  print $_;
1113 }
1114 print $_;
1115 ####
1116 # [perl #47361] do({}) and do +{} (variants of do-file)
1117 do({});
1118 do +{};
1119 sub foo::do {}
1120 package foo;
1121 CORE::do({});
1122 CORE::do +{};
1123 >>>>
1124 do({});
1125 do({});
1126 package foo;
1127 CORE::do({});
1128 CORE::do({});
1129 ####
1130 # [perl #77096] functions that do not follow the llafr
1131 () = (return 1) + time;
1132 () = (return ($1 + $2) * $3) + time;
1133 () = (return ($a xor $b)) + time;
1134 () = (do 'file') + time;
1135 () = (do ($1 + $2) * $3) + time;
1136 () = (do ($1 xor $2)) + time;
1137 () = (goto 1) + 3;
1138 () = (require 'foo') + 3;
1139 () = (require foo) + 3;
1140 () = (CORE::dump 1) + 3;
1141 () = (last 1) + 3;
1142 () = (next 1) + 3;
1143 () = (redo 1) + 3;
1144 () = (-R $_) + 3;
1145 () = (-W $_) + 3;
1146 () = (-X $_) + 3;
1147 () = (-r $_) + 3;
1148 () = (-w $_) + 3;
1149 () = (-x $_) + 3;
1150 ####
1151 # [perl #97476] not() *does* follow the llafr
1152 $_ = ($a xor not +($1 || 2) ** 2);
1153 ####
1154 # Precedence conundrums with argument-less function calls
1155 () = (eof) + 1;
1156 () = (return) + 1;
1157 () = (return, 1);
1158 () = warn;
1159 () = warn() + 1;
1160 () = setpgrp() + 1;
1161 ####
1162 # loopexes have assignment prec
1163 () = (CORE::dump a) | 'b';
1164 () = (goto a) | 'b';
1165 () = (last a) | 'b';
1166 () = (next a) | 'b';
1167 () = (redo a) | 'b';
1168 ####
1169 # [perl #63558] open local(*FH)
1170 open local *FH;
1171 pipe local *FH, local *FH;
1172 ####
1173 # [perl #91416] open "string"
1174 open 'open';
1175 open '####';
1176 open '^A';
1177 open "\ca";
1178 >>>>
1179 open *open;
1180 open '####';
1181 open '^A';
1182 open *^A;
1183 ####
1184 # "string"->[] ->{}
1185 no strict 'vars';
1186 () = 'open'->[0]; #aelemfast
1187 () = '####'->[0];
1188 () = '^A'->[0];
1189 () = "\ca"->[0];
1190 () = 'a::]b'->[0];
1191 () = 'open'->[$_]; #aelem
1192 () = '####'->[$_];
1193 () = '^A'->[$_];
1194 () = "\ca"->[$_];
1195 () = 'a::]b'->[$_];
1196 () = 'open'->{0}; #helem
1197 () = '####'->{0};
1198 () = '^A'->{0};
1199 () = "\ca"->{0};
1200 () = 'a::]b'->{0};
1201 >>>>
1202 no strict 'vars';
1203 () = $open[0];
1204 () = '####'->[0];
1205 () = '^A'->[0];
1206 () = $^A[0];
1207 () = 'a::]b'->[0];
1208 () = $open[$_];
1209 () = '####'->[$_];
1210 () = '^A'->[$_];
1211 () = $^A[$_];
1212 () = 'a::]b'->[$_];
1213 () = $open{'0'};
1214 () = '####'->{'0'};
1215 () = '^A'->{'0'};
1216 () = $^A{'0'};
1217 () = 'a::]b'->{'0'};
1218 ####
1219 # [perl #74740] -(f()) vs -f()
1220 $_ = -(f());
1221 ####
1222 # require <binop>
1223 require 'a' . $1;
1224 ####
1225 #[perl #30504] foreach-my postfix/prefix difference
1226 $_ = 'foo' foreach my ($foo1, $bar1, $baz1);
1227 foreach (my ($foo2, $bar2, $baz2)) { $_ = 'foo' }
1228 foreach my $i (my ($foo3, $bar3, $baz3)) { $i = 'foo' }
1229 >>>>
1230 $_ = 'foo' foreach (my($foo1, $bar1, $baz1));
1231 foreach $_ (my($foo2, $bar2, $baz2)) {
1232     $_ = 'foo';
1233 }
1234 foreach my $i (my($foo3, $bar3, $baz3)) {
1235     $i = 'foo';
1236 }
1237 ####
1238 #[perl #108224] foreach with continue block
1239 foreach (1 .. 3) { print } continue { print "\n" }
1240 foreach (1 .. 3) { } continue { }
1241 foreach my $i (1 .. 3) { print $i } continue { print "\n" }
1242 foreach my $i (1 .. 3) { } continue { }
1243 >>>>
1244 foreach $_ (1 .. 3) {
1245     print $_;
1246 }
1247 continue {
1248     print "\n";
1249 }
1250 foreach $_ (1 .. 3) {
1251     ();
1252 }
1253 continue {
1254     ();
1255 }
1256 foreach my $i (1 .. 3) {
1257     print $i;
1258 }
1259 continue {
1260     print "\n";
1261 }
1262 foreach my $i (1 .. 3) {
1263     ();
1264 }
1265 continue {
1266     ();
1267 }
1268 ####
1269 # file handles
1270 no strict;
1271 my $mfh;
1272 open F;
1273 open *F;
1274 open $fh;
1275 open $mfh;
1276 open 'a+b';
1277 select *F;
1278 select F;
1279 select $f;
1280 select $mfh;
1281 select 'a+b';
1282 ####
1283 # 'my' works with padrange op
1284 my($z, @z);
1285 my $m1;
1286 $m1 = 1;
1287 $z = $m1;
1288 my $m2 = 2;
1289 my($m3, $m4);
1290 ($m3, $m4) = (1, 2);
1291 @z = ($m3, $m4);
1292 my($m5, $m6) = (1, 2);
1293 my($m7, undef, $m8) = (1, 2, 3);
1294 @z = ($m7, undef, $m8);
1295 ($m7, undef, $m8) = (1, 2, 3);
1296 ####
1297 # 'our/local' works with padrange op
1298 no strict;
1299 our($z, @z);
1300 our $o1;
1301 local $o11;
1302 $o1 = 1;
1303 local $o1 = 1;
1304 $z = $o1;
1305 $z = local $o1;
1306 our $o2 = 2;
1307 our($o3, $o4);
1308 ($o3, $o4) = (1, 2);
1309 local($o3, $o4) = (1, 2);
1310 @z = ($o3, $o4);
1311 @z = local($o3, $o4);
1312 our($o5, $o6) = (1, 2);
1313 our($o7, undef, $o8) = (1, 2, 3);
1314 @z = ($o7, undef, $o8);
1315 @z = local($o7, undef, $o8);
1316 ($o7, undef, $o8) = (1, 2, 3);
1317 local($o7, undef, $o8) = (1, 2, 3);
1318 ####
1319 # 'state' works with padrange op
1320 no strict;
1321 use feature 'state';
1322 state($z, @z);
1323 state $s1;
1324 $s1 = 1;
1325 $z = $s1;
1326 state $s2 = 2;
1327 state($s3, $s4);
1328 ($s3, $s4) = (1, 2);
1329 @z = ($s3, $s4);
1330 # assignment of state lists isn't implemented yet
1331 #state($s5, $s6) = (1, 2);
1332 #state($s7, undef, $s8) = (1, 2, 3);
1333 #@z = ($s7, undef, $s8);
1334 ($s7, undef, $s8) = (1, 2, 3);
1335 ####
1336 # anon lists with padrange
1337 my($a, $b);
1338 my $c = [$a, $b];
1339 my $d = {$a, $b};
1340 ####
1341 # slices with padrange
1342 my($a, $b);
1343 my(@x, %y);
1344 @x = @x[$a, $b];
1345 @x = @y{$a, $b};
1346 ####
1347 # binops with padrange
1348 my($a, $b, $c);
1349 $c = $a cmp $b;
1350 $c = $a + $b;
1351 $a += $b;
1352 $c = $a - $b;
1353 $a -= $b;
1354 $c = my $a1 cmp $b;
1355 $c = my $a2 + $b;
1356 $a += my $b1;
1357 $c = my $a3 - $b;
1358 $a -= my $b2;
1359 ####
1360 # 'x' with padrange
1361 my($a, $b, $c, $d, @e);
1362 $c = $a x $b;
1363 $a x= $b;
1364 @e = ($a) x $d;
1365 @e = ($a, $b) x $d;
1366 @e = ($a, $b, $c) x $d;
1367 @e = ($a, 1) x $d;