lib/B/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     require 'test.pl';
  11 }
  12
  13 use warnings;
  14 use strict;
  15
  16 my $tests = 30; # 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         SKIP: { 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     # parse options if necessary
  61     my $deparse = $meta{options}
  62         ? $deparse{$meta{options}} ||=
  63             new B::Deparse split /,/, $meta{options}
  64         : $deparse;
  65
  66     my $coderef = eval "$meta{context};\n" . <<'EOC' . "sub {$input\n}";
  67 # Tell B::Deparse about our ambient pragmas
  68 my ($hint_bits, $warning_bits, $hinthash);
  69 BEGIN {
  70     ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H);
  71 }
  72 $deparse->ambient_pragmas (
  73     hint_bits    => $hint_bits,
  74     warning_bits => $warning_bits,
  75     '%^H'        => $hinthash,
  76 );
  77 EOC
  78
  79     local $::TODO = $meta{todo};
  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         like($deparsed, qr/$regex/, $desc);
  91     }
  92 }
  93
  94 # Reset the ambient pragmas
  95 {
  96     my ($b, $w, $h);
  97     BEGIN {
  98         ($b, $w, $h) = ($^H, ${^WARNING_BITS}, \%^H);
  99     }
 100     $deparse->ambient_pragmas (
 101         hint_bits    => $b,
 102         warning_bits => $w,
 103         '%^H'        => $h,
 104     );
 105 }
 106
 107 use constant 'c', 'stuff';
 108 is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff',
 109    'the subroutine generated by use constant deparses');
 110
 111 my $a = 0;
 112 is($deparse->coderef2text(sub{(-1) ** $a }), "{\n    (-1) ** \$a;\n}",
 113    'anon sub capturing an external lexical');
 114
 115 use constant cr => ['hello'];
 116 my $string = "sub " . $deparse->coderef2text(\&cr);
 117 my $val = (eval $string)->() or diag $string;
 118 is(ref($val), 'ARRAY', 'constant array references deparse');
 119 is($val->[0], 'hello', 'and return the correct value');
 120
 121 my $path = join " ", map { qq["-I$_"] } @INC;
 122
 123 $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 2>&1`;
 124 $a =~ s/-e syntax OK\n//g;
 125 $a =~ s/.*possible typo.*\n//;     # Remove warning line
 126 $a =~ s/.*-i used with no filenames.*\n//;      # Remove warning line
 127 $b = quotemeta <<'EOF';
 128 BEGIN { $^I = ".bak"; }
 129 BEGIN { $^W = 1; }
 130 BEGIN { $/ = "\n"; $\ = "\n"; }
 131 LINE: while (defined($_ = <ARGV>)) {
 132     chomp $_;
 133     our(@F) = split(' ', $_, 0);
 134     '???';
 135 }
 136 EOF
 137 $b =~ s/our\\\(\\\@F\\\)/our[( ]\@F\\)?/; # accept both our @F and our(@F)
 138 like($a, qr/$b/,
 139    'command line flags deparse as BEGIN blocks setting control variables');
 140
 141 $a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`;
 142 $a =~ s/-e syntax OK\n//g;
 143 is($a, "();\nuse constant ('PI', 4);\n",
 144    "Proxy Constant Subroutines must not show up as (incorrect) prototypes");
 145
 146 #Re: perlbug #35857, patch #24505
 147 #handle warnings::register-ed packages properly.
 148 package B::Deparse::Wrapper;
 149 use strict;
 150 use warnings;
 151 use warnings::register;
 152 sub getcode {
 153    my $deparser = B::Deparse->new();
 154    return $deparser->coderef2text(shift);
 155 }
 156
 157 package Moo;
 158 use overload '0+' => sub { 42 };
 159
 160 package main;
 161 use strict;
 162 use warnings;
 163 use constant GLIPP => 'glipp';
 164 use constant PI => 4;
 165 use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo');
 166 use Fcntl qw/O_TRUNC O_APPEND O_EXCL/;
 167 BEGIN { delete $::Fcntl::{O_APPEND}; }
 168 use POSIX qw/O_CREAT/;
 169 sub test {
 170    my $val = shift;
 171    my $res = B::Deparse::Wrapper::getcode($val);
 172    like($res, qr/use warnings/,
 173         '[perl #35857] [PATCH] B::Deparse doesnt handle warnings register properly');
 174 }
 175 my ($q,$p);
 176 my $x=sub { ++$q,++$p };
 177 test($x);
 178 eval <<EOFCODE and test($x);
 179    package bar;
 180    use strict;
 181    use warnings;
 182    use warnings::register;
 183    package main;
 184    1
 185 EOFCODE
 186
 187 # Exotic sub declarations
 188 $a = `$^X $path "-MO=Deparse" -e "sub ::::{}sub ::::::{}" 2>&1`;
 189 $a =~ s/-e syntax OK\n//g;
 190 is($a, <<'EOCODG', "sub :::: and sub ::::::");
 191 ();
 192 sub :::: {
 193
 194 }
 195 sub :::::: {
 196
 197 }
 198 EOCODG
 199
 200 # [perl #117311]
 201 $a = `$^X $path "-MO=Deparse,-l" -e "map{ eval(0) }()" 2>&1`;
 202 $a =~ s/-e syntax OK\n//g;
 203 is($a, <<'EOCODH', "[perl #117311] [PATCH] -l option ('#line ...') does not emit ^Ls in the output");
 204 #line 1 "-e"
 205 map {
 206 #line 1 "-e"
 207 eval 0;} ();
 208 EOCODH
 209
 210 # [perl #33752]
 211 {
 212   my $code = <<"EOCODE";
 213 {
 214     our \$\x{1e1f}\x{14d}\x{14d};
 215 }
 216 EOCODE
 217   my $deparsed
 218    = $deparse->coderef2text(eval "sub { our \$\x{1e1f}\x{14d}\x{14d} }" );
 219   s/$ \n//x for $deparsed, $code;
 220   is $deparsed, $code, 'our $funny_Unicode_chars';
 221 }
 222
 223 # [perl #62500]
 224 $a =
 225   `$^X $path "-MO=Deparse" -e "BEGIN{*CORE::GLOBAL::require=sub{1}}" 2>&1`;
 226 $a =~ s/-e syntax OK\n//g;
 227 is($a, <<'EOCODF', "CORE::GLOBAL::require override causing panick");
 228 ();
 229 sub BEGIN {
 230     *CORE::GLOBAL::require = sub {
 231         1;
 232     }
 233     ;
 234 }
 235 EOCODF
 236
 237 # [perl #91384]
 238 $a =
 239   `$^X $path "-MO=Deparse" -e "BEGIN{*Acme::Acme:: = *Acme::}" 2>&1`;
 240 like($a, qr/-e syntax OK/,
 241     "Deparse does not hang when traversing stash circularities");
 242
 243 # [perl #93990]
 244 @] = ();
 245 is($deparse->coderef2text(sub{ print "foo@{]}" }),
 246 q<{
 247     print "foo@{]}";
 248 }>, 'curly around to interpolate "@{]}"');
 249 is($deparse->coderef2text(sub{ print "foo@{-}" }),
 250 q<{
 251     print "foo@-";
 252 }>, 'no need to curly around to interpolate "@-"');
 253
 254 # Strict hints in %^H are mercilessly suppressed
 255 $a =
 256   `$^X $path "-MO=Deparse" -e "use strict; print;" 2>&1`;
 257 unlike($a, qr/BEGIN/,
 258     "Deparse does not emit strict hh hints");
 259
 260 # ambient_pragmas should not mess with strict settings.
 261 SKIP: {
 262     skip "requires 5.11", 1 unless $] >= 5.011;
 263     eval q`
 264         BEGIN {
 265             # Clear out all hints
 266             %^H = ();
 267             $^H = 0;
 268             new B::Deparse -> ambient_pragmas(strict => 'all');
 269         }
 270         use 5.011;  # should enable strict
 271         ok !eval '$do_noT_create_a_variable_with_this_name = 1',
 272           'ambient_pragmas do not mess with compiling scope';
 273    `;
 274 }
 275
 276 # multiple statements on format lines
 277 $a = `$^X $path "-MO=Deparse" -e "format =" -e "\@" -e "x();z()" -e. 2>&1`;
 278 $a =~ s/-e syntax OK\n//g;
 279 is($a, <<'EOCODH', 'multiple statements on format lines');
 280 format STDOUT =
 281 @
 282 x(); z()
 283 .
 284 EOCODH
 285
 286 # CORE::format
 287 $a = readpipe qq`$^X $path "-MO=Deparse" -e "use feature q|:all|;`
 288              .qq` my sub format; CORE::format =" -e. 2>&1`;
 289 like($a, qr/CORE::format/, 'CORE::format when lex format sub is in scope');
 290
 291 # literal big chars under 'use utf8'
 292 is($deparse->coderef2text(sub{ use utf8; /€/; }),
 293 '{
 294     /\x{20ac}/;
 295 }',
 296 "qr/euro/");
 297
 298 # STDERR when deparsing sub calls
 299 # For a short while the output included 'While deparsing'
 300 $a = `$^X $path "-MO=Deparse" -e "foo()" 2>&1`;
 301 $a =~ s/-e syntax OK\n//g;
 302 is($a, <<'EOCODI', 'no extra output when deparsing foo()');
 303 foo();
 304 EOCODI
 305
 306 # CORE::no
 307 $a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
 308              .qq`"use feature q|:all|; my sub no; CORE::no less" 2>&1`;
 309 like($a, qr/my sub no;\nCORE::no less;/,
 310     'CORE::no after my sub no');
 311
 312 # CORE::use
 313 $a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
 314              .qq`"use feature q|:all|; my sub use; CORE::use less" 2>&1`;
 315 like($a, qr/my sub use;\nCORE::use less;/,
 316     'CORE::use after my sub use');
 317
 318 # CORE::__DATA__
 319 $a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
 320              .qq`"use feature q|:all|; my sub __DATA__; `
 321              .qq`CORE::__DATA__" 2>&1`;
 322 like($a, qr/my sub __DATA__;\n.*\nCORE::__DATA__/s,
 323     'CORE::__DATA__ after my sub __DATA__');
 324
 325 # sub declarations
 326 $a = readpipe qq`$^X $path "-MO=Deparse" -e "sub foo{}" 2>&1`;
 327 like($a, qr/sub foo\s*\{\s+\}/, 'sub declarations');
 328
 329 # BEGIN blocks
 330 SKIP : {
 331     skip "BEGIN output is wrong on old perls", 1 if $] < 5.021006;
 332     my $prog = '
 333       BEGIN { pop }
 334       {
 335         BEGIN { pop }
 336         {
 337           no overloading;
 338           {
 339             BEGIN { pop }
 340             die
 341           }
 342         }
 343       }';
 344     $prog =~ s/\n//g;
 345     $a = readpipe qq`$^X $path "-MO=Deparse" -e "$prog" 2>&1`;
 346     $a =~ s/-e syntax OK\n//g;
 347     is($a, <<'EOCODJ', 'BEGIN blocks');
 348 sub BEGIN {
 349     pop @ARGV;
 350 }
 351 {
 352     sub BEGIN {
 353         pop @ARGV;
 354     }
 355     {
 356         no overloading;
 357         {
 358             sub BEGIN {
 359                 pop @ARGV;
 360             }
 361             die;
 362         }
 363     }
 364 }
 365 EOCODJ
 366 }
 367 is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], prog => '
 368       {
 369         {
 370           die;
 371           BEGIN { pop }
 372         }
 373         BEGIN { pop }
 374       }
 375       BEGIN { pop }
 376   '), <<'EOCODL', 'BEGIN blocks at the end of their enclosing blocks';
 377 {
 378     {
 379         die;
 380         sub BEGIN {
 381             pop @ARGV;
 382         }
 383     }
 384     sub BEGIN {
 385         pop @ARGV;
 386     }
 387 }
 388 sub BEGIN {
 389     pop @ARGV;
 390 }
 391 EOCODL
 392
 393 # [perl #115066]
 394 my $prog = 'use constant FOO => do { 1 }; no overloading; die';
 395 $a = readpipe qq`$^X $path "-MO=-qq,Deparse" -e "$prog" 2>&1`;
 396 is($a, <<'EOCODK', '[perl #115066] use statements accidentally nested');
 397 use constant ('FOO', do {
 398     1
 399 });
 400 no overloading;
 401 die;
 402 EOCODK
 403
 404 like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
 405              prog => 'use feature lexical_subs=>; my sub f;sub main::f{}'),
 406      qr/^sub main::f \{/m,
 407     'sub decl when lex sub is in scope';
 408
 409 done_testing($tests);
 410
 411 __DATA__
 412 # TODO [perl #120950] This succeeds when run a 2nd time
 413 # y/uni/code/
 414 tr/\x{345}/\x{370}/;
 415 ####
 416 # y/uni/code/  [perl #120950] This 2nd instance succeeds
 417 tr/\x{345}/\x{370}/;
 418 ####
 419 # A constant
 420 1;
 421 ####
 422 # Constants in a block
 423 # CONTEXT no warnings;
 424 {
 425     '???';
 426     2;
 427 }
 428 ####
 429 # Lexical and simple arithmetic
 430 my $test;
 431 ++$test and $test /= 2;
 432 >>>>
 433 my $test;
 434 $test /= 2 if ++$test;
 435 ####
 436 # list x
 437 -((1, 2) x 2);
 438 ####
 439 # Assignment to list x
 440 ((undef) x 3) = undef;
 441 ####
 442 # lvalue sub
 443 {
 444     my $test = sub : lvalue {
 445         my $x;
 446     }
 447     ;
 448 }
 449 ####
 450 # method
 451 {
 452     my $test = sub : method {
 453         my $x;
 454     }
 455     ;
 456 }
 457 ####
 458 # anonsub attrs at statement start
 459 my $x = do { +sub : lvalue { my $y; } };
 460 my $z = do { foo: +sub : method { my $a; } };
 461 ####
 462 # block with continue
 463 {
 464     234;
 465 }
 466 continue {
 467     123;
 468 }
 469 ####
 470 # lexical and package scalars
 471 my $x;
 472 print $main::x;
 473 ####
 474 # lexical and package arrays
 475 my @x;
 476 print $main::x[1];
 477 ####
 478 # lexical and package hashes
 479 my %x;
 480 $x{warn()};
 481 ####
 482 # our (LIST)
 483 our($foo, $bar, $baz);
 484 ####
 485 # CONTEXT { package Dog } use feature "state";
 486 # variables with declared classes
 487 my Dog $spot;
 488 our Dog $spotty;
 489 state Dog $spotted;
 490 my Dog @spot;
 491 our Dog @spotty;
 492 state Dog @spotted;
 493 my Dog %spot;
 494 our Dog %spotty;
 495 state Dog %spotted;
 496 my Dog ($foo, @bar, %baz);
 497 our Dog ($phoo, @barr, %bazz);
 498 state Dog ($fough, @barre, %bazze);
 499 ####
 500 # local our
 501 local our $rhubarb;
 502 local our($rhu, $barb);
 503 ####
 504 # <>
 505 my $foo;
 506 $_ .= <ARGV> . <$foo>;
 507 ####
 508 # \x{}
 509 my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ";
 510 ####
 511 # s///e
 512 s/x/'y';/e;
 513 s/x/$a;/e;
 514 s/x/complex_expression();/e;
 515 ####
 516 # block
 517 { my $x; }
 518 ####
 519 # while 1
 520 while (1) { my $k; }
 521 ####
 522 # trailing for
 523 my ($x,@a);
 524 $x=1 for @a;
 525 >>>>
 526 my($x, @a);
 527 $x = 1 foreach (@a);
 528 ####
 529 # 2 arguments in a 3 argument for
 530 for (my $i = 0; $i < 2;) {
 531     my $z = 1;
 532 }
 533 ####
 534 # 3 argument for
 535 for (my $i = 0; $i < 2; ++$i) {
 536     my $z = 1;
 537 }
 538 ####
 539 # 3 argument for again
 540 for (my $i = 0; $i < 2; ++$i) {
 541     my $z = 1;
 542 }
 543 ####
 544 # 3-argument for with inverted condition
 545 for (my $i; not $i;) {
 546     die;
 547 }
 548 for (my $i; not $i; ++$i) {
 549     die;
 550 }
 551 for (my $a; not +($1 || 2) ** 2;) {
 552     die;
 553 }
 554 Something_to_put_the_loop_in_void_context();
 555 ####
 556 # while/continue
 557 my $i;
 558 while ($i) { my $z = 1; } continue { $i = 99; }
 559 ####
 560 # foreach with my
 561 foreach my $i (1, 2) {
 562     my $z = 1;
 563 }
 564 ####
 565 # OPTIONS -p
 566 # foreach with my under -p
 567 foreach my $i (1) {
 568     die;
 569 }
 570 ####
 571 # foreach
 572 my $i;
 573 foreach $i (1, 2) {
 574     my $z = 1;
 575 }
 576 ####
 577 # foreach, 2 mys
 578 my $i;
 579 foreach my $i (1, 2) {
 580     my $z = 1;
 581 }
 582 ####
 583 # foreach with our
 584 foreach our $i (1, 2) {
 585     my $z = 1;
 586 }
 587 ####
 588 # foreach with my and our
 589 my $i;
 590 foreach our $i (1, 2) {
 591     my $z = 1;
 592 }
 593 ####
 594 # foreach with state
 595 # CONTEXT use feature "state";
 596 foreach state $i (1, 2) {
 597     state $z = 1;
 598 }
 599 ####
 600 # reverse sort
 601 my @x;
 602 print reverse sort(@x);
 603 ####
 604 # sort with cmp
 605 my @x;
 606 print((sort {$b cmp $a} @x));
 607 ####
 608 # reverse sort with block
 609 my @x;
 610 print((reverse sort {$b <=> $a} @x));
 611 ####
 612 # foreach reverse
 613 our @a;
 614 print $_ foreach (reverse @a);
 615 ####
 616 # foreach reverse (not inplace)
 617 our @a;
 618 print $_ foreach (reverse 1, 2..5);
 619 ####
 620 # bug #38684
 621 our @ary;
 622 @ary = split(' ', 'foo', 0);
 623 ####
 624 # Split to our array
 625 our @array = split(//, 'foo', 0);
 626 ####
 627 # Split to my array
 628 my @array  = split(//, 'foo', 0);
 629 ####
 630 # bug #40055
 631 do { () };
 632 ####
 633 # bug #40055
 634 do { my $x = 1; $x };
 635 ####
 636 # <20061012113037.GJ25805@c4.convolution.nl>
 637 my $f = sub {
 638     +{[]};
 639 } ;
 640 ####
 641 # bug #43010
 642 '!@$%'->();
 643 ####
 644 # bug #43010
 645 ::();
 646 ####
 647 # bug #43010
 648 '::::'->();
 649 ####
 650 # bug #43010
 651 &::::;
 652 ####
 653 # [perl #77172]
 654 package rt77172;
 655 sub foo {} foo & & & foo;
 656 >>>>
 657 package rt77172;
 658 foo(&{&} & foo());
 659 ####
 660 # variables as method names
 661 my $bar;
 662 'Foo'->$bar('orz');
 663 'Foo'->$bar('orz') = 'a stranger stranger than before';
 664 ####
 665 # constants as method names
 666 'Foo'->bar('orz');
 667 ####
 668 # constants as method names without ()
 669 'Foo'->bar;
 670 ####
 671 # [perl #47359] "indirect" method call notation
 672 our @bar;
 673 foo{@bar}+1,->foo;
 674 (foo{@bar}+1),foo();
 675 foo{@bar}1 xor foo();
 676 >>>>
 677 our @bar;
 678 (foo { @bar } 1)->foo;
 679 (foo { @bar } 1), foo();
 680 foo { @bar } 1 xor foo();
 681 ####
 682 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 683 # CONTEXT use feature ':5.10';
 684 # say
 685 say 'foo';
 686 ####
 687 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 688 # CONTEXT use 5.10.0;
 689 # say in the context of use 5.10.0
 690 say 'foo';
 691 ####
 692 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 693 # say with use 5.10.0
 694 use 5.10.0;
 695 say 'foo';
 696 >>>>
 697 no feature;
 698 use feature ':5.10';
 699 say 'foo';
 700 ####
 701 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 702 # say with use feature ':5.10';
 703 use feature ':5.10';
 704 say 'foo';
 705 >>>>
 706 use feature 'say', 'state', 'switch';
 707 say 'foo';
 708 ####
 709 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 710 # CONTEXT use feature ':5.10';
 711 # say with use 5.10.0 in the context of use feature
 712 use 5.10.0;
 713 say 'foo';
 714 >>>>
 715 no feature;
 716 use feature ':5.10';
 717 say 'foo';
 718 ####
 719 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 720 # CONTEXT use 5.10.0;
 721 # say with use feature ':5.10' in the context of use 5.10.0
 722 use feature ':5.10';
 723 say 'foo';
 724 >>>>
 725 say 'foo';
 726 ####
 727 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
 728 # CONTEXT use feature ':5.15';
 729 # __SUB__
 730 __SUB__;
 731 ####
 732 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
 733 # CONTEXT use 5.15.0;
 734 # __SUB__ in the context of use 5.15.0
 735 __SUB__;
 736 ####
 737 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
 738 # __SUB__ with use 5.15.0
 739 use 5.15.0;
 740 __SUB__;
 741 >>>>
 742 no feature;
 743 use feature ':5.16';
 744 __SUB__;
 745 ####
 746 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
 747 # __SUB__ with use feature ':5.15';
 748 use feature ':5.15';
 749 __SUB__;
 750 >>>>
 751 use feature 'current_sub', 'evalbytes', 'fc', 'say', 'state', 'switch', 'unicode_strings', 'unicode_eval';
 752 __SUB__;
 753 ####
 754 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
 755 # CONTEXT use feature ':5.15';
 756 # __SUB__ with use 5.15.0 in the context of use feature
 757 use 5.15.0;
 758 __SUB__;
 759 >>>>
 760 no feature;
 761 use feature ':5.16';
 762 __SUB__;
 763 ####
 764 # SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
 765 # CONTEXT use 5.15.0;
 766 # __SUB__ with use feature ':5.15' in the context of use 5.15.0
 767 use feature ':5.15';
 768 __SUB__;
 769 >>>>
 770 __SUB__;
 771 ####
 772 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 773 # CONTEXT use feature ':5.10';
 774 # state vars
 775 state $x = 42;
 776 ####
 777 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 778 # CONTEXT use feature ':5.10';
 779 # state var assignment
 780 {
 781     my $y = (state $x = 42);
 782 }
 783 ####
 784 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
 785 # CONTEXT use feature ':5.10';
 786 # state vars in anonymous subroutines
 787 $a = sub {
 788     state $x;
 789     return $x++;
 790 }
 791 ;
 792 ####
 793 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
 794 # each @array;
 795 each @ARGV;
 796 each @$a;
 797 ####
 798 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
 799 # keys @array; values @array
 800 keys @$a if keys @ARGV;
 801 values @ARGV if values @$a;
 802 ####
 803 # Anonymous arrays and hashes, and references to them
 804 my $a = {};
 805 my $b = \{};
 806 my $c = [];
 807 my $d = \[];
 808 ####
 809 # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
 810 # CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch';
 811 # implicit smartmatch in given/when
 812 given ('foo') {
 813     when ('bar') { continue; }
 814     when ($_ ~~ 'quux') { continue; }
 815     default { 0; }
 816 }
 817 ####
 818 # conditions in elsifs (regression in change #33710 which fixed bug #37302)
 819 if ($a) { x(); }
 820 elsif ($b) { x(); }
 821 elsif ($a and $b) { x(); }
 822 elsif ($a or $b) { x(); }
 823 else { x(); }
 824 ####
 825 # interpolation in regexps
 826 my($y, $t);
 827 /x${y}z$t/;
 828 ####
 829 # TODO new undocumented cpan-bug #33708
 830 # cpan-bug #33708
 831 %{$_ || {}}
 832 ####
 833 # TODO hash constants not yet fixed
 834 # cpan-bug #33708
 835 use constant H => { "#" => 1 }; H->{"#"}
 836 ####
 837 # TODO optimized away 0 not yet fixed
 838 # cpan-bug #33708
 839 foreach my $i (@_) { 0 }
 840 ####
 841 # tests with not, not optimized
 842 my $c;
 843 x() unless $a;
 844 x() if not $a and $b;
 845 x() if $a and not $b;
 846 x() unless not $a and $b;
 847 x() unless $a and not $b;
 848 x() if not $a or $b;
 849 x() if $a or not $b;
 850 x() unless not $a or $b;
 851 x() unless $a or not $b;
 852 x() if $a and not $b and $c;
 853 x() if not $a and $b and not $c;
 854 x() unless $a and not $b and $c;
 855 x() unless not $a and $b and not $c;
 856 x() if $a or not $b or $c;
 857 x() if not $a or $b or not $c;
 858 x() unless $a or not $b or $c;
 859 x() unless not $a or $b or not $c;
 860 ####
 861 # tests with not, optimized
 862 my $c;
 863 x() if not $a;
 864 x() unless not $a;
 865 x() if not $a and not $b;
 866 x() unless not $a and not $b;
 867 x() if not $a or not $b;
 868 x() unless not $a or not $b;
 869 x() if not $a and not $b and $c;
 870 x() unless not $a and not $b and $c;
 871 x() if not $a or not $b or $c;
 872 x() unless not $a or not $b or $c;
 873 x() if not $a and not $b and not $c;
 874 x() unless not $a and not $b and not $c;
 875 x() if not $a or not $b or not $c;
 876 x() unless not $a or not $b or not $c;
 877 x() unless not $a or not $b or not $c;
 878 >>>>
 879 my $c;
 880 x() unless $a;
 881 x() if $a;
 882 x() unless $a or $b;
 883 x() if $a or $b;
 884 x() unless $a and $b;
 885 x() if $a and $b;
 886 x() if not $a || $b and $c;
 887 x() unless not $a || $b and $c;
 888 x() if not $a && $b or $c;
 889 x() unless not $a && $b or $c;
 890 x() unless $a or $b or $c;
 891 x() if $a or $b or $c;
 892 x() unless $a and $b and $c;
 893 x() if $a and $b and $c;
 894 x() unless not $a && $b && $c;
 895 ####
 896 # tests that should be constant folded
 897 x() if 1;
 898 x() if GLIPP;
 899 x() if !GLIPP;
 900 x() if GLIPP && GLIPP;
 901 x() if !GLIPP || GLIPP;
 902 x() if do { GLIPP };
 903 x() if do { no warnings 'void'; 5; GLIPP };
 904 x() if do { !GLIPP };
 905 if (GLIPP) { x() } else { z() }
 906 if (!GLIPP) { x() } else { z() }
 907 if (GLIPP) { x() } elsif (GLIPP) { z() }
 908 if (!GLIPP) { x() } elsif (GLIPP) { z() }
 909 if (GLIPP) { x() } elsif (!GLIPP) { z() }
 910 if (!GLIPP) { x() } elsif (!GLIPP) { z() }
 911 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
 912 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
 913 if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
 914 >>>>
 915 x();
 916 x();
 917 '???';
 918 x();
 919 x();
 920 x();
 921 x();
 922 do {
 923     '???'
 924 };
 925 do {
 926     x()
 927 };
 928 do {
 929     z()
 930 };
 931 do {
 932     x()
 933 };
 934 do {
 935     z()
 936 };
 937 do {
 938     x()
 939 };
 940 '???';
 941 do {
 942     t()
 943 };
 944 '???';
 945 !1;
 946 ####
 947 # TODO constant deparsing has been backed out for 5.12
 948 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
 949 # tests that shouldn't be constant folded
 950 # It might be fundamentally impossible to make this work on ithreads, in which
 951 # case the TODO should become a SKIP
 952 x() if $a;
 953 if ($a == 1) { x() } elsif ($b == 2) { z() }
 954 if (do { foo(); GLIPP }) { x() }
 955 if (do { $a++; GLIPP }) { x() }
 956 >>>>
 957 x() if $a;
 958 if ($a == 1) { x(); } elsif ($b == 2) { z(); }
 959 if (do { foo(); GLIPP }) { x(); }
 960 if (do { ++$a; GLIPP }) { x(); }
 961 ####
 962 # TODO constant deparsing has been backed out for 5.12
 963 # tests for deparsing constants
 964 warn PI;
 965 ####
 966 # TODO constant deparsing has been backed out for 5.12
 967 # tests for deparsing imported constants
 968 warn O_TRUNC;
 969 ####
 970 # TODO constant deparsing has been backed out for 5.12
 971 # tests for deparsing re-exported constants
 972 warn O_CREAT;
 973 ####
 974 # TODO constant deparsing has been backed out for 5.12
 975 # tests for deparsing imported constants that got deleted from the original namespace
 976 warn O_APPEND;
 977 ####
 978 # TODO constant deparsing has been backed out for 5.12
 979 # XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
 980 # tests for deparsing constants which got turned into full typeglobs
 981 # It might be fundamentally impossible to make this work on ithreads, in which
 982 # case the TODO should become a SKIP
 983 warn O_EXCL;
 984 eval '@Fcntl::O_EXCL = qw/affe tiger/;';
 985 warn O_EXCL;
 986 ####
 987 # TODO constant deparsing has been backed out for 5.12
 988 # tests for deparsing of blessed constant with overloaded numification
 989 warn OVERLOADED_NUMIFICATION;
 990 ####
 991 # strict
 992 no strict;
 993 print $x;
 994 use strict 'vars';
 995 print $main::x;
 996 use strict 'subs';
 997 print $main::x;
 998 use strict 'refs';
 999 print $main::x;
1000 no strict 'vars';
1001 $x;
1002 ####
1003 # TODO Subsets of warnings could be encoded textually, rather than as bitflips.
1004 # subsets of warnings
1005 no warnings 'deprecated';
1006 my $x;
1007 ####
1008 # TODO Better test for CPAN #33708 - the deparsed code has different behaviour
1009 # CPAN #33708
1010 use strict;
1011 no warnings;
1012
1013 foreach (0..3) {
1014     my $x = 2;
1015     {
1016         my $x if 0;
1017         print ++$x, "\n";
1018     }
1019 }
1020 ####
1021 # no attribute list
1022 my $pi = 4;
1023 ####
1024 # SKIP ?$] > 5.013006 && ":= is now a syntax error"
1025 # := treated as an empty attribute list
1026 no warnings;
1027 my $pi := 4;
1028 >>>>
1029 no warnings;
1030 my $pi = 4;
1031 ####
1032 # : = empty attribute list
1033 my $pi : = 4;
1034 >>>>
1035 my $pi = 4;
1036 ####
1037 # in place sort
1038 our @a;
1039 my @b;
1040 @a = sort @a;
1041 @b = sort @b;
1042 ();
1043 ####
1044 # in place reverse
1045 our @a;
1046 my @b;
1047 @a = reverse @a;
1048 @b = reverse @b;
1049 ();
1050 ####
1051 # #71870 Use of uninitialized value in bitwise and B::Deparse
1052 my($r, $s, @a);
1053 @a = split(/foo/, $s, 0);
1054 $r = qr/foo/;
1055 @a = split(/$r/, $s, 0);
1056 ();
1057 ####
1058 # package declaration before label
1059 {
1060     package Foo;
1061     label: print 123;
1062 }
1063 ####
1064 # shift optimisation
1065 shift;
1066 >>>>
1067 shift();
1068 ####
1069 # shift optimisation
1070 shift @_;
1071 ####
1072 # shift optimisation
1073 pop;
1074 >>>>
1075 pop();
1076 ####
1077 # shift optimisation
1078 pop @_;
1079 ####
1080 #[perl #20444]
1081 "foo" =~ (1 ? /foo/ : /bar/);
1082 "foo" =~ (1 ? y/foo// : /bar/);
1083 "foo" =~ (1 ? y/foo//r : /bar/);
1084 "foo" =~ (1 ? s/foo// : /bar/);
1085 >>>>
1086 'foo' =~ ($_ =~ /foo/);
1087 'foo' =~ ($_ =~ tr/fo//);
1088 'foo' =~ ($_ =~ tr/fo//r);
1089 'foo' =~ ($_ =~ s/foo//);
1090 ####
1091 # The fix for [perl #20444] broke this.
1092 'foo' =~ do { () };
1093 ####
1094 # [perl #81424] match against aelemfast_lex
1095 my @s;
1096 print /$s[1]/;
1097 ####
1098 # /$#a/
1099 print /$#main::a/;
1100 ####
1101 # $lexical =~ //
1102 my $x;
1103 $x =~ //;
1104 ####
1105 # [perl #91318] /regexp/applaud
1106 print /a/a, s/b/c/a;
1107 print /a/aa, s/b/c/aa;
1108 print /a/p, s/b/c/p;
1109 print /a/l, s/b/c/l;
1110 print /a/u, s/b/c/u;
1111 {
1112     use feature "unicode_strings";
1113     print /a/d, s/b/c/d;
1114 }
1115 {
1116     use re "/u";
1117     print /a/d, s/b/c/d;
1118 }
1119 {
1120     use 5.012;
1121     print /a/d, s/b/c/d;
1122 }
1123 >>>>
1124 print /a/a, s/b/c/a;
1125 print /a/aa, s/b/c/aa;
1126 print /a/p, s/b/c/p;
1127 print /a/l, s/b/c/l;
1128 print /a/u, s/b/c/u;
1129 {
1130     use feature 'unicode_strings';
1131     print /a/d, s/b/c/d;
1132 }
1133 {
1134     BEGIN { $^H{'reflags'}         = '0';
1135             $^H{'reflags_charset'} = '2'; }
1136     print /a/d, s/b/c/d;
1137 }
1138 {
1139     no feature;
1140     use feature ':5.12';
1141     print /a/d, s/b/c/d;
1142 }
1143 ####
1144 # [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns)
1145 s/foo/\(3);/eg;
1146 ####
1147 # [perl #115256]
1148 "" =~ /a(?{ print q|
1149 |})/;
1150 >>>>
1151 '' =~ /a(?{ print "\n"; })/;
1152 ####
1153 # [perl #123217]
1154 $_ = qr/(??{<<END})/
1155 f.o
1156 b.r
1157 END
1158 >>>>
1159 $_ = qr/(??{ "f.o\nb.r\n"; })/;
1160 ####
1161 # More regexp code block madness
1162 my($b, @a);
1163 /(?{ die $b; })/;
1164 /a(?{ die $b; })a/;
1165 /$a(?{ die $b; })/;
1166 /@a(?{ die $b; })/;
1167 /(??{ die $b; })/;
1168 /a(??{ die $b; })a/;
1169 /$a(??{ die $b; })/;
1170 /@a(??{ die $b; })/;
1171 qr/(?{ die $b; })/;
1172 qr/a(?{ die $b; })a/;
1173 qr/$a(?{ die $b; })/;
1174 qr/@a(?{ die $b; })/;
1175 qr/(??{ die $b; })/;
1176 qr/a(??{ die $b; })a/;
1177 qr/$a(??{ die $b; })/;
1178 qr/@a(??{ die $b; })/;
1179 s/(?{ die $b; })//;
1180 s/a(?{ die $b; })a//;
1181 s/$a(?{ die $b; })//;
1182 s/@a(?{ die $b; })//;
1183 s/(??{ die $b; })//;
1184 s/a(??{ die $b; })a//;
1185 s/$a(??{ die $b; })//;
1186 s/@a(??{ die $b; })//;
1187 ####
1188 # y///r
1189 tr/a/b/r + $a =~ tr/p/q/r;
1190 ####
1191 # y///d in list [perl #119815]
1192 () = tr/a//d;
1193 ####
1194 # [perl #90898]
1195 <a,>;
1196 ####
1197 # [perl #91008]
1198 # CONTEXT no warnings 'experimental::autoderef';
1199 each $@;
1200 keys $~;
1201 values $!;
1202 ####
1203 # readpipe with complex expression
1204 readpipe $a + $b;
1205 ####
1206 # aelemfast
1207 $b::a[0] = 1;
1208 ####
1209 # aelemfast for a lexical
1210 my @a;
1211 $a[0] = 1;
1212 ####
1213 # feature features without feature
1214 # CONTEXT no warnings 'experimental::smartmatch';
1215 CORE::state $x;
1216 CORE::say $x;
1217 CORE::given ($x) {
1218     CORE::when (3) {
1219         continue;
1220     }
1221     CORE::default {
1222         CORE::break;
1223     }
1224 }
1225 CORE::evalbytes '';
1226 () = CORE::__SUB__;
1227 () = CORE::fc $x;
1228 ####
1229 # feature features when feature has been disabled by use VERSION
1230 # CONTEXT no warnings 'experimental::smartmatch';
1231 use feature (sprintf(":%vd", $^V));
1232 use 1;
1233 CORE::say $_;
1234 CORE::state $x;
1235 CORE::given ($x) {
1236     CORE::when (3) {
1237         continue;
1238     }
1239     CORE::default {
1240         CORE::break;
1241     }
1242 }
1243 CORE::evalbytes '';
1244 () = CORE::__SUB__;
1245 >>>>
1246 CORE::say $_;
1247 CORE::state $x;
1248 CORE::given ($x) {
1249     CORE::when (3) {
1250         continue;
1251     }
1252     CORE::default {
1253         CORE::break;
1254     }
1255 }
1256 CORE::evalbytes '';
1257 () = CORE::__SUB__;
1258 ####
1259 # (the above test with CONTEXT, and the output is equivalent but different)
1260 # CONTEXT use feature ':5.10'; no warnings 'experimental::smartmatch';
1261 # feature features when feature has been disabled by use VERSION
1262 use feature (sprintf(":%vd", $^V));
1263 use 1;
1264 CORE::say $_;
1265 CORE::state $x;
1266 CORE::given ($x) {
1267     CORE::when (3) {
1268         continue;
1269     }
1270     CORE::default {
1271         CORE::break;
1272     }
1273 }
1274 CORE::evalbytes '';
1275 () = CORE::__SUB__;
1276 >>>>
1277 no feature;
1278 use feature ':default';
1279 CORE::say $_;
1280 CORE::state $x;
1281 CORE::given ($x) {
1282     CORE::when (3) {
1283         continue;
1284     }
1285     CORE::default {
1286         CORE::break;
1287     }
1288 }
1289 CORE::evalbytes '';
1290 () = CORE::__SUB__;
1291 ####
1292 # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
1293 # lexical subroutines and keywords of the same name
1294 # CONTEXT use feature 'lexical_subs', 'switch'; no warnings 'experimental';
1295 my sub default;
1296 my sub else;
1297 my sub elsif;
1298 my sub for;
1299 my sub foreach;
1300 my sub given;
1301 my sub if;
1302 my sub m;
1303 my sub no;
1304 my sub package;
1305 my sub q;
1306 my sub qq;
1307 my sub qr;
1308 my sub qx;
1309 my sub require;
1310 my sub s;
1311 my sub sub;
1312 my sub tr;
1313 my sub unless;
1314 my sub until;
1315 my sub use;
1316 my sub when;
1317 my sub while;
1318 CORE::default { die; }
1319 CORE::if ($1) { die; }
1320 CORE::if ($1) { die; }
1321 CORE::elsif ($1) { die; }
1322 CORE::else { die; }
1323 CORE::for (die; $1; die) { die; }
1324 CORE::foreach $_ (1 .. 10) { die; }
1325 die CORE::foreach (1);
1326 CORE::given ($1) { die; }
1327 CORE::m[/];
1328 CORE::m?/?;
1329 CORE::package foo;
1330 CORE::no strict;
1331 () = (CORE::q['], CORE::qq["$_], CORE::qr//, CORE::qx[`]);
1332 CORE::require 1;
1333 CORE::s///;
1334 () = CORE::sub { die; } ;
1335 CORE::tr///;
1336 CORE::unless ($1) { die; }
1337 CORE::until ($1) { die; }
1338 die CORE::until $1;
1339 CORE::use strict;
1340 CORE::when ($1 ~~ $2) { die; }
1341 CORE::while ($1) { die; }
1342 die CORE::while $1;
1343 ####
1344 # Feature hints
1345 use feature 'current_sub', 'evalbytes';
1346 print;
1347 use 1;
1348 print;
1349 use 5.014;
1350 print;
1351 no feature 'unicode_strings';
1352 print;
1353 >>>>
1354 use feature 'current_sub', 'evalbytes';
1355 print $_;
1356 no feature;
1357 use feature ':default';
1358 print $_;
1359 no feature;
1360 use feature ':5.12';
1361 print $_;
1362 no feature 'unicode_strings';
1363 print $_;
1364 ####
1365 # $#- $#+ $#{%} etc.
1366 my @x;
1367 @x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*});
1368 @x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,});
1369 @x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-);
1370 @x = ($#{;}, $#{:});
1371 ####
1372 # ${#} interpolated
1373 # It's a known TODO that warnings are deparsed as bits, not textually.
1374 no warnings;
1375 () = "${#}a";
1376 ####
1377 # [perl #86060] $( $| $) in regexps need braces
1378 /${(}/;
1379 /${|}/;
1380 /${)}/;
1381 /${(}${|}${)}/;
1382 ####
1383 # ()[...]
1384 my(@a) = ()[()];
1385 ####
1386 # sort(foo(bar))
1387 # sort(foo(bar)) is interpreted as sort &foo(bar)
1388 # sort foo(bar) is interpreted as sort foo bar
1389 # parentheses are not optional in this case
1390 print sort(foo('bar'));
1391 >>>>
1392 print sort(foo('bar'));
1393 ####
1394 # substr assignment
1395 substr(my $a, 0, 0) = (foo(), bar());
1396 $a++;
1397 ####
1398 # This following line works around an unfixed bug that we are not trying to
1399 # test for here:
1400 # CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
1401 # hint hash
1402 BEGIN { $^H{'foo'} = undef; }
1403 {
1404  BEGIN { $^H{'bar'} = undef; }
1405  {
1406   BEGIN { $^H{'baz'} = undef; }
1407   {
1408    print $_;
1409   }
1410   print $_;
1411  }
1412  print $_;
1413 }
1414 BEGIN { $^H{q[']} = '('; }
1415 print $_;
1416 ####
1417 # This following line works around an unfixed bug that we are not trying to
1418 # test for here:
1419 # CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
1420 # hint hash changes that serialise the same way with sort %hh
1421 BEGIN { $^H{'a'} = 'b'; }
1422 {
1423  BEGIN { $^H{'b'} = 'a'; delete $^H{'a'}; }
1424  print $_;
1425 }
1426 print $_;
1427 ####
1428 # [perl #47361] do({}) and do +{} (variants of do-file)
1429 do({});
1430 do +{};
1431 sub foo::do {}
1432 package foo;
1433 CORE::do({});
1434 CORE::do +{};
1435 >>>>
1436 do({});
1437 do({});
1438 package foo;
1439 CORE::do({});
1440 CORE::do({});
1441 ####
1442 # [perl #77096] functions that do not follow the llafr
1443 () = (return 1) + time;
1444 () = (return ($1 + $2) * $3) + time;
1445 () = (return ($a xor $b)) + time;
1446 () = (do 'file') + time;
1447 () = (do ($1 + $2) * $3) + time;
1448 () = (do ($1 xor $2)) + time;
1449 () = (goto 1) + 3;
1450 () = (require 'foo') + 3;
1451 () = (require foo) + 3;
1452 () = (CORE::dump 1) + 3;
1453 () = (last 1) + 3;
1454 () = (next 1) + 3;
1455 () = (redo 1) + 3;
1456 () = (-R $_) + 3;
1457 () = (-W $_) + 3;
1458 () = (-X $_) + 3;
1459 () = (-r $_) + 3;
1460 () = (-w $_) + 3;
1461 () = (-x $_) + 3;
1462 ####
1463 # [perl #97476] not() *does* follow the llafr
1464 $_ = ($a xor not +($1 || 2) ** 2);
1465 ####
1466 # Precedence conundrums with argument-less function calls
1467 () = (eof) + 1;
1468 () = (return) + 1;
1469 () = (return, 1);
1470 () = warn;
1471 () = warn() + 1;
1472 () = setpgrp() + 1;
1473 ####
1474 # loopexes have assignment prec
1475 () = (CORE::dump a) | 'b';
1476 () = (goto a) | 'b';
1477 () = (last a) | 'b';
1478 () = (next a) | 'b';
1479 () = (redo a) | 'b';
1480 ####
1481 # [perl #63558] open local(*FH)
1482 open local *FH;
1483 pipe local *FH, local *FH;
1484 ####
1485 # [perl #91416] open "string"
1486 open 'open';
1487 open '####';
1488 open '^A';
1489 open "\ca";
1490 >>>>
1491 open *open;
1492 open '####';
1493 open '^A';
1494 open *^A;
1495 ####
1496 # "string"->[] ->{}
1497 no strict 'vars';
1498 () = 'open'->[0]; #aelemfast
1499 () = '####'->[0];
1500 () = '^A'->[0];
1501 () = "\ca"->[0];
1502 () = 'a::]b'->[0];
1503 () = 'open'->[$_]; #aelem
1504 () = '####'->[$_];
1505 () = '^A'->[$_];
1506 () = "\ca"->[$_];
1507 () = 'a::]b'->[$_];
1508 () = 'open'->{0}; #helem
1509 () = '####'->{0};
1510 () = '^A'->{0};
1511 () = "\ca"->{0};
1512 () = 'a::]b'->{0};
1513 >>>>
1514 no strict 'vars';
1515 () = $open[0];
1516 () = '####'->[0];
1517 () = '^A'->[0];
1518 () = $^A[0];
1519 () = 'a::]b'->[0];
1520 () = $open[$_];
1521 () = '####'->[$_];
1522 () = '^A'->[$_];
1523 () = $^A[$_];
1524 () = 'a::]b'->[$_];
1525 () = $open{'0'};
1526 () = '####'->{'0'};
1527 () = '^A'->{'0'};
1528 () = $^A{'0'};
1529 () = 'a::]b'->{'0'};
1530 ####
1531 # [perl #74740] -(f()) vs -f()
1532 $_ = -(f());
1533 ####
1534 # require <binop>
1535 require 'a' . $1;
1536 ####
1537 #[perl #30504] foreach-my postfix/prefix difference
1538 $_ = 'foo' foreach my ($foo1, $bar1, $baz1);
1539 foreach (my ($foo2, $bar2, $baz2)) { $_ = 'foo' }
1540 foreach my $i (my ($foo3, $bar3, $baz3)) { $i = 'foo' }
1541 >>>>
1542 $_ = 'foo' foreach (my($foo1, $bar1, $baz1));
1543 foreach $_ (my($foo2, $bar2, $baz2)) {
1544     $_ = 'foo';
1545 }
1546 foreach my $i (my($foo3, $bar3, $baz3)) {
1547     $i = 'foo';
1548 }
1549 ####
1550 #[perl #108224] foreach with continue block
1551 foreach (1 .. 3) { print } continue { print "\n" }
1552 foreach (1 .. 3) { } continue { }
1553 foreach my $i (1 .. 3) { print $i } continue { print "\n" }
1554 foreach my $i (1 .. 3) { } continue { }
1555 >>>>
1556 foreach $_ (1 .. 3) {
1557     print $_;
1558 }
1559 continue {
1560     print "\n";
1561 }
1562 foreach $_ (1 .. 3) {
1563     ();
1564 }
1565 continue {
1566     ();
1567 }
1568 foreach my $i (1 .. 3) {
1569     print $i;
1570 }
1571 continue {
1572     print "\n";
1573 }
1574 foreach my $i (1 .. 3) {
1575     ();
1576 }
1577 continue {
1578     ();
1579 }
1580 ####
1581 # file handles
1582 no strict;
1583 my $mfh;
1584 open F;
1585 open *F;
1586 open $fh;
1587 open $mfh;
1588 open 'a+b';
1589 select *F;
1590 select F;
1591 select $f;
1592 select $mfh;
1593 select 'a+b';
1594 ####
1595 # 'my' works with padrange op
1596 my($z, @z);
1597 my $m1;
1598 $m1 = 1;
1599 $z = $m1;
1600 my $m2 = 2;
1601 my($m3, $m4);
1602 ($m3, $m4) = (1, 2);
1603 @z = ($m3, $m4);
1604 my($m5, $m6) = (1, 2);
1605 my($m7, undef, $m8) = (1, 2, 3);
1606 @z = ($m7, undef, $m8);
1607 ($m7, undef, $m8) = (1, 2, 3);
1608 ####
1609 # 'our/local' works with padrange op
1610 our($z, @z);
1611 our $o1;
1612 no strict;
1613 local $o11;
1614 $o1 = 1;
1615 local $o1 = 1;
1616 $z = $o1;
1617 $z = local $o1;
1618 our $o2 = 2;
1619 our($o3, $o4);
1620 ($o3, $o4) = (1, 2);
1621 local($o3, $o4) = (1, 2);
1622 @z = ($o3, $o4);
1623 @z = local($o3, $o4);
1624 our($o5, $o6) = (1, 2);
1625 our($o7, undef, $o8) = (1, 2, 3);
1626 @z = ($o7, undef, $o8);
1627 @z = local($o7, undef, $o8);
1628 ($o7, undef, $o8) = (1, 2, 3);
1629 local($o7, undef, $o8) = (1, 2, 3);
1630 ####
1631 # 'state' works with padrange op
1632 # CONTEXT no strict; use feature 'state';
1633 state($z, @z);
1634 state $s1;
1635 $s1 = 1;
1636 $z = $s1;
1637 state $s2 = 2;
1638 state($s3, $s4);
1639 ($s3, $s4) = (1, 2);
1640 @z = ($s3, $s4);
1641 # assignment of state lists isn't implemented yet
1642 #state($s5, $s6) = (1, 2);
1643 #state($s7, undef, $s8) = (1, 2, 3);
1644 #@z = ($s7, undef, $s8);
1645 ($s7, undef, $s8) = (1, 2, 3);
1646 ####
1647 # anon arrays with padrange
1648 my($a, $b);
1649 my $c = [$a, $b];
1650 my $d = {$a, $b};
1651 ####
1652 # slices with padrange
1653 my($a, $b);
1654 my(@x, %y);
1655 @x = @x[$a, $b];
1656 @x = @y{$a, $b};
1657 ####
1658 # binops with padrange
1659 my($a, $b, $c);
1660 $c = $a cmp $b;
1661 $c = $a + $b;
1662 $a += $b;
1663 $c = $a - $b;
1664 $a -= $b;
1665 $c = my $a1 cmp $b;
1666 $c = my $a2 + $b;
1667 $a += my $b1;
1668 $c = my $a3 - $b;
1669 $a -= my $b2;
1670 ####
1671 # 'x' with padrange
1672 my($a, $b, $c, $d, @e);
1673 $c = $a x $b;
1674 $a x= $b;
1675 @e = ($a) x $d;
1676 @e = ($a, $b) x $d;
1677 @e = ($a, $b, $c) x $d;
1678 @e = ($a, 1) x $d;
1679 ####
1680 # @_ with padrange
1681 my($a, $b, $c) = @_;
1682 ####
1683 # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
1684 # lexical subroutine
1685 use feature 'lexical_subs';
1686 no warnings "experimental::lexical_subs";
1687 my sub f {}
1688 print f();
1689 >>>>
1690 use feature 'lexical_subs';
1691 BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUUU\005"}
1692 my sub f {
1693     BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUU\005"}
1694
1695 }
1696 BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUU\005"}
1697 print f();
1698 ####
1699 # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
1700 # lexical "state" subroutine
1701 use feature 'state', 'lexical_subs';
1702 no warnings 'experimental::lexical_subs';
1703 state sub f {}
1704 print f();
1705 >>>>
1706 use feature 'lexical_subs';
1707 BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUUU\005"}
1708 CORE::state sub f {
1709     BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUU\005"}
1710     use feature 'state';
1711
1712 }
1713 BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUU\005"}
1714 use feature 'state';
1715 print f();
1716 ####
1717 # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
1718 # lexical subroutine scoping
1719 # CONTEXT use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
1720 {
1721   {
1722     my sub a { die; }
1723     {
1724       foo();
1725       my sub b;
1726       b();
1727       main::b();
1728       &main::b;
1729       &main::b();
1730       my $b = \&main::b;
1731       sub b { $b; }
1732     }
1733   }
1734   b();
1735 }
1736 ####
1737 # Elements of %# should not be confused with $#{ array }
1738 () = ${#}{'foo'};
1739 ####
1740 # [perl #121050] Prototypes with whitespace
1741 sub _121050(\$ \$) { }
1742 _121050($a,$b);
1743 sub _121050empty( ) {}
1744 () = _121050empty() + 1;
1745 >>>>
1746 _121050 $a, $b;
1747 () = _121050empty + 1;
1748 ####
1749 # ensure aelemfast works in the range -128..127 and that there's no
1750 # funky edge cases
1751 my $x;
1752 no strict 'vars';
1753 $x = $a[-256] + $a[-255] + $a[-129] + $a[-128] + $a[-127] + $a[-1] + $a[0];
1754 $x = $a[1] + $a[126] + $a[127] + $a[128] + $a[255] + $a[256];
1755 my @b;
1756 $x = $b[-256] + $b[-255] + $b[-129] + $b[-128] + $b[-127] + $b[-1] + $b[0];
1757 $x = $b[1] + $b[126] + $b[127] + $b[128] + $b[255] + $b[256];
1758 ####
1759 # 'm' must be preserved in m??
1760 m??;
1761 ####
1762 # \(@array) and \(..., (@array), ...)
1763 my(@array, %hash, @a, @b, %c, %d);
1764 () = \(@array);
1765 () = \(%hash);
1766 () = \(@a, (@b), (%c), %d);
1767 () = \(@Foo::array);
1768 () = \(%Foo::hash);
1769 () = \(@Foo::a, (@Foo::b), (%Foo::c), %Foo::d);
1770 ####
1771 # subs synonymous with keywords
1772 main::our();
1773 main::pop();
1774 state();
1775 use feature 'state';
1776 main::state();
1777 ####
1778 # lvalue references
1779 # CONTEXT use feature "state", 'refaliasing', 'lexical_subs'; no warnings 'experimental';
1780 our $x;
1781 \$x = \$x;
1782 my $m;
1783 \$m = \$x;
1784 \my $n = \$x;
1785 (\$x) = @_;
1786 \($x) = @_;
1787 \($m) = @_;
1788 (\$m) = @_;
1789 \my($p) = @_;
1790 (\my $r) = @_;
1791 \($x, my $a) = @{[\$x, \$x]};
1792 (\$x, \my $b) = @{[\$x, \$x]};
1793 \local $x = \3;
1794 \local($x) = \3;
1795 \state $c = \3;
1796 \state($d) = \3;
1797 \our $e = \3;
1798 \our($f) = \3;
1799 \$_[0] = foo();
1800 \($_[1]) = foo();
1801 my @a;
1802 \$a[0] = foo();
1803 \($a[1]) = foo();
1804 \local($a[1]) = foo();
1805 \@a[0,1] = foo();
1806 \(@a[2,3]) = foo();
1807 \local @a[0,1] = (\$a)x2;
1808 \$_{a} = foo();
1809 \($_{b}) = foo();
1810 my %h;
1811 \$h{a} = foo();
1812 \($h{b}) = foo();
1813 \local $h{a} = \$x;
1814 \local($h{b}) = \$x;
1815 \@h{'a','b'} = foo();
1816 \(@h{2,3}) = foo();
1817 \local @h{'a','b'} = (\$x)x2;
1818 \@_ = foo();
1819 \@a = foo();
1820 (\@_) = foo();
1821 (\@a) = foo();
1822 \my @c = foo();
1823 (\my @d) = foo();
1824 \(@_) = foo();
1825 \(@a) = foo();
1826 \my(@g) = foo();
1827 \local @_ = \@_;
1828 (\local @_) = \@_;
1829 \state @e = [1..3];
1830 \state(@f) = \3;
1831 \our @i = [1..3];
1832 \our(@h) = \3;
1833 \%_ = foo();
1834 \%h = foo();
1835 (\%_) = foo();
1836 (\%h) = foo();
1837 \my %c = foo();
1838 (\my %d) = foo();
1839 \local %_ = \%h;
1840 (\local %_) = \%h;
1841 \state %y = {1,2};
1842 \our %z = {1,2};
1843 (\our %zz) = {1,2};
1844 \&a = foo();
1845 (\&a) = foo();
1846 \(&a) = foo();
1847 {
1848   my sub a;
1849   \&a = foo();
1850   (\&a) = foo();
1851   \(&a) = foo();
1852 }
1853 (\$_, $_) = \(1, 2);
1854 $_ == 3 ? \$_ : $_ = \3;
1855 $_ == 3 ? \$_ : \$x = \3;
1856 \($_ == 3 ? $_ : $x) = \3;
1857 for \my $topic (\$1, \$2) {
1858     die;
1859 }
1860 for \state $topic (\$1, \$2) {
1861     die;
1862 }
1863 for \our $topic (\$1, \$2) {
1864     die;
1865 }
1866 for \$_ (\$1, \$2) {
1867     die;
1868 }
1869 for \my @a ([1,2], [3,4]) {
1870     die;
1871 }
1872 for \state @a ([1,2], [3,4]) {
1873     die;
1874 }
1875 for \our @a ([1,2], [3,4]) {
1876     die;
1877 }
1878 for \@_ ([1,2], [3,4]) {
1879     die;
1880 }
1881 for \my %a ({5,6}, {7,8}) {
1882     die;
1883 }
1884 for \our %a ({5,6}, {7,8}) {
1885     die;
1886 }
1887 for \state %a ({5,6}, {7,8}) {
1888     die;
1889 }
1890 for \%_ ({5,6}, {7,8}) {
1891     die;
1892 }
1893 {
1894     my sub a;
1895     for \&a (sub { 9; }, sub { 10; }) {
1896         die;
1897     }
1898 }
1899 for \&a (sub { 9; }, sub { 10; }) {
1900     die;
1901 }
1902 >>>>
1903 our $x;
1904 \$x = \$x;
1905 my $m;
1906 \$m = \$x;
1907 \my $n = \$x;
1908 (\$x) = @_;
1909 (\$x) = @_;
1910 (\$m) = @_;
1911 (\$m) = @_;
1912 (\my $p) = @_;
1913 (\my $r) = @_;
1914 (\$x, \my $a) = @{[\$x, \$x];};
1915 (\$x, \my $b) = @{[\$x, \$x];};
1916 \local $x = \3;
1917 (\local $x) = \3;
1918 \state $c = \3;
1919 (\state $d) = \3;
1920 \our $e = \3;
1921 (\our $f) = \3;
1922 \$_[0] = foo();
1923 (\$_[1]) = foo();
1924 my @a;
1925 \$a[0] = foo();
1926 (\$a[1]) = foo();
1927 (\local $a[1]) = foo();
1928 (\@a[0, 1]) = foo();
1929 (\@a[2, 3]) = foo();
1930 (\local @a[0, 1]) = (\$a) x 2;
1931 \$_{'a'} = foo();
1932 (\$_{'b'}) = foo();
1933 my %h;
1934 \$h{'a'} = foo();
1935 (\$h{'b'}) = foo();
1936 \local $h{'a'} = \$x;
1937 (\local $h{'b'}) = \$x;
1938 (\@h{'a', 'b'}) = foo();
1939 (\@h{2, 3}) = foo();
1940 (\local @h{'a', 'b'}) = (\$x) x 2;
1941 \@_ = foo();
1942 \@a = foo();
1943 (\@_) = foo();
1944 (\@a) = foo();
1945 \my @c = foo();
1946 (\my @d) = foo();
1947 (\(@_)) = foo();
1948 (\(@a)) = foo();
1949 (\(my @g)) = foo();
1950 \local @_ = \@_;
1951 (\local @_) = \@_;
1952 \state @e = [1..3];
1953 (\(state @f)) = \3;
1954 \our @i = [1..3];
1955 (\(our @h)) = \3;
1956 \%_ = foo();
1957 \%h = foo();
1958 (\%_) = foo();
1959 (\%h) = foo();
1960 \my %c = foo();
1961 (\my %d) = foo();
1962 \local %_ = \%h;
1963 (\local %_) = \%h;
1964 \state %y = {1, 2};
1965 \our %z = {1, 2};
1966 (\our %zz) = {1, 2};
1967 \&a = foo();
1968 (\&a) = foo();
1969 (\&a) = foo();
1970 {
1971   my sub a;
1972   \&a = foo();
1973   (\&a) = foo();
1974   (\&a) = foo();
1975 }
1976 (\$_, $_) = \(1, 2);
1977 $_ == 3 ? \$_ : $_ = \3;
1978 $_ == 3 ? \$_ : \$x = \3;
1979 ($_ == 3 ? \$_ : \$x) = \3;
1980 foreach \my $topic (\$1, \$2) {
1981     die;
1982 }
1983 foreach \state $topic (\$1, \$2) {
1984     die;
1985 }
1986 foreach \our $topic (\$1, \$2) {
1987     die;
1988 }
1989 foreach \$_ (\$1, \$2) {
1990     die;
1991 }
1992 foreach \my @a ([1, 2], [3, 4]) {
1993     die;
1994 }
1995 foreach \state @a ([1, 2], [3, 4]) {
1996     die;
1997 }
1998 foreach \our @a ([1, 2], [3, 4]) {
1999     die;
2000 }
2001 foreach \@_ ([1, 2], [3, 4]) {
2002     die;
2003 }
2004 foreach \my %a ({5, 6}, {7, 8}) {
2005     die;
2006 }
2007 foreach \our %a ({5, 6}, {7, 8}) {
2008     die;
2009 }
2010 foreach \state %a ({5, 6}, {7, 8}) {
2011     die;
2012 }
2013 foreach \%_ ({5, 6}, {7, 8}) {
2014     die;
2015 }
2016 {
2017     my sub a;
2018     foreach \&a (sub { 9; } , sub { 10; } ) {
2019         die;
2020     }
2021 }
2022 foreach \&a (sub { 9; } , sub { 10; } ) {
2023     die;
2024 }
2025 ####
2026 # join $foo, pos
2027 my $foo;
2028 $_ = join $foo, pos
2029 >>>>
2030 my $foo;
2031 $_ = join('???', pos $_);