new perldelta

[perl5.git] / lib / B / Deparse.t

#!./perl

BEGIN {
    splice @INC, 0, 0, 't', '.';
    require Config;
    if (($Config::Config{'extensions'} !~ /\bB\b/) ){
        print "1..0 # Skip -- Perl configured without B module\n";
        exit 0;
    }
    require 'test.pl';
}

use warnings;
use strict;

my $tests = 52; # not counting those in the __DATA__ section

use B::Deparse;
my $deparse = B::Deparse->new();
isa_ok($deparse, 'B::Deparse', 'instantiate a B::Deparse object');
my %deparse;

sub dummy_sub {42}

$/ = "\n####\n";
while (<DATA>) {
    chomp;
    $tests ++;
    # This code is pinched from the t/lib/common.pl for TODO.
    # It's not clear how to avoid duplication
    my %meta = (context => '');
    foreach my $what (qw(skip todo context options)) {
	s/^#\s*\U$what\E\s*(.*)\n//m and $meta{$what} = $1;
	# If the SKIP reason starts ? then it's taken as a code snippet to
	# evaluate. This provides the flexibility to have conditional SKIPs
	if ($meta{$what} && $meta{$what} =~ s/^\?//) {
	    my $temp = eval $meta{$what};
	    if ($@) {
		die "# In \U$what\E code reason:\n# $meta{$what}\n$@";
	    }
	    $meta{$what} = $temp;
	}
    }

    s/^\s*#\s*(.*)$//mg;
    my $desc = $1;
    die "Missing name in test $_" unless defined $desc;

    if ($meta{skip}) {
	SKIP: { skip($meta{skip}) };
	next;
    }

    my ($input, $expected);
    if (/(.*)\n>>>>\n(.*)/s) {
	($input, $expected) = ($1, $2);
    }
    else {
	($input, $expected) = ($_, $_);
    }

    # parse options if necessary
    my $deparse = $meta{options}
	? $deparse{$meta{options}} ||=
	    B::Deparse->new(split /,/, $meta{options})
	: $deparse;

    my $code = "$meta{context};\n" . <<'EOC' . "sub {$input\n}";
# Tell B::Deparse about our ambient pragmas
my ($hint_bits, $warning_bits, $hinthash);
BEGIN {
    ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H);
}
$deparse->ambient_pragmas (
    hint_bits    => $hint_bits,
    warning_bits => $warning_bits,
    '%^H'        => $hinthash,
);
EOC
    my $coderef = eval $code;

    local $::TODO = $meta{todo};
    if ($@) {
	is($@, "", "compilation of $desc")
            or diag "=============================================\n"
                  . "CODE:\n--------\n$code\n--------\n"
                  . "=============================================\n";
    }
    else {
	my $deparsed = $deparse->coderef2text( $coderef );
	my $regex = $expected;
	$regex =~ s/(\S+)/\Q$1/g;
	$regex =~ s/\s+/\\s+/g;
	$regex = '^\{\s*' . $regex . '\s*\}$';

        like($deparsed, qr/$regex/, $desc)
            or diag "=============================================\n"
                  . "CODE:\n--------\n$input\n--------\n"
                  . "EXPECTED:\n--------\n{\n$expected\n}\n--------\n"
                  . "GOT:\n--------\n$deparsed\n--------\n"
                  . "=============================================\n";
    }
}

# Reset the ambient pragmas
{
    my ($b, $w, $h);
    BEGIN {
        ($b, $w, $h) = ($^H, ${^WARNING_BITS}, \%^H);
    }
    $deparse->ambient_pragmas (
        hint_bits    => $b,
        warning_bits => $w,
        '%^H'        => $h,
    );
}

use constant 'c', 'stuff';
is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff',
   'the subroutine generated by use constant deparses');

my $a = 0;
is($deparse->coderef2text(sub{(-1) ** $a }), "{\n    (-1) ** \$a;\n}",
   'anon sub capturing an external lexical');

use constant cr => ['hello'];
my $string = "sub " . $deparse->coderef2text(\&cr);
my $val = (eval $string)->() or diag $string;
is(ref($val), 'ARRAY', 'constant array references deparse');
is($val->[0], 'hello', 'and return the correct value');

my $path = join " ", map { qq["-I$_"] } @INC;

$a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 2>&1`;
$a =~ s/-e syntax OK\n//g;
$a =~ s/.*possible typo.*\n//;	   # Remove warning line
$a =~ s/.*-i used with no filenames.*\n//;	# Remove warning line
$b = quotemeta <<'EOF';
BEGIN { $^I = ".bak"; }
BEGIN { $^W = 1; }
BEGIN { $/ = "\n"; $\ = "\n"; }
LINE: while (defined($_ = readline ARGV)) {
    chomp $_;
    our(@F) = split(' ', $_, 0);
    '???';
}
EOF
$b =~ s/our\\\(\\\@F\\\)/our[( ]\@F\\)?/; # accept both our @F and our(@F)
like($a, qr/$b/,
   'command line flags deparse as BEGIN blocks setting control variables');

$a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`;
$a =~ s/-e syntax OK\n//g;
is($a, "use constant ('PI', 4);\n",
   "Proxy Constant Subroutines must not show up as (incorrect) prototypes");

$a = `$^X $path "-MO=Deparse" -e "sub foo(){1}" 2>&1`;
$a =~ s/-e syntax OK\n//g;
is($a, "sub foo () {\n    1;\n}\n",
   "Main prog consisting of just a constant (via empty proto)");

$a = readpipe qq|$^X $path "-MO=Deparse"|
             .qq| -e "package F; sub f(){0} sub s{}"|
             .qq| -e "#line 123 four-five-six"|
             .qq| -e "package G; sub g(){0} sub s{}" 2>&1|;
$a =~ s/-e syntax OK\n//g;
like($a, qr/sub F::f \(\) \{\s*0;?\s*}/,
   "Constant is dumped in package in which other subs are dumped");
unlike($a, qr/sub g/,
   "Constant is not dumped in package in which other subs are not dumped");

#Re: perlbug #35857, patch #24505
#handle warnings::register-ed packages properly.
package B::Deparse::Wrapper;
use strict;
use warnings;
use warnings::register;
sub getcode {
   my $deparser = B::Deparse->new();
   return $deparser->coderef2text(shift);
}

package Moo;
use overload '0+' => sub { 42 };

package main;
use strict;
use warnings;
use constant GLIPP => 'glipp';
use constant PI => 4;
use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo');
use Fcntl qw/O_TRUNC O_APPEND O_EXCL/;
BEGIN { delete $::Fcntl::{O_APPEND}; }
use POSIX qw/O_CREAT/;
sub test {
   my $val = shift;
   my $res = B::Deparse::Wrapper::getcode($val);
   like($res, qr/use warnings/,
	'[perl #35857] [PATCH] B::Deparse doesnt handle warnings register properly');
}
my ($q,$p);
my $x=sub { ++$q,++$p };
test($x);
eval <<EOFCODE and test($x);
   package bar;
   use strict;
   use warnings;
   use warnings::register;
   package main;
   1
EOFCODE

# Exotic sub declarations
$a = `$^X $path "-MO=Deparse" -e "sub ::::{}sub ::::::{}" 2>&1`;
$a =~ s/-e syntax OK\n//g;
is($a, <<'EOCODG', "sub :::: and sub ::::::");
sub :::: {
    
}
sub :::::: {
    
}
EOCODG

# [perl #117311]
$a = `$^X $path "-MO=Deparse,-l" -e "map{ eval(0) }()" 2>&1`;
$a =~ s/-e syntax OK\n//g;
is($a, <<'EOCODH', "[perl #117311] [PATCH] -l option ('#line ...') does not emit ^Ls in the output");
#line 1 "-e"
map {
#line 1 "-e"
eval 0;} ();
EOCODH

# [perl #33752]
{
  my $code = <<"EOCODE";
{
    our \$\x{1e1f}\x{14d}\x{14d};
}
EOCODE
  my $deparsed
   = $deparse->coderef2text(eval "sub { our \$\x{1e1f}\x{14d}\x{14d} }" );
  s/$ \n//x for $deparsed, $code;
  is $deparsed, $code, 'our $funny_Unicode_chars';
}

# [perl #62500]
$a =
  `$^X $path "-MO=Deparse" -e "BEGIN{*CORE::GLOBAL::require=sub{1}}" 2>&1`;
$a =~ s/-e syntax OK\n//g;
is($a, <<'EOCODF', "CORE::GLOBAL::require override causing panick");
sub BEGIN {
    *CORE::GLOBAL::require = sub {
        1;
    }
    ;
}
EOCODF

# [perl #91384]
$a =
  `$^X $path "-MO=Deparse" -e "BEGIN{*Acme::Acme:: = *Acme::}" 2>&1`;
like($a, qr/-e syntax OK/,
    "Deparse does not hang when traversing stash circularities");

# [perl #93990]
@] = ();
is($deparse->coderef2text(sub{ print "foo@{]}" }),
q<{
    print "foo@{]}";
}>, 'curly around to interpolate "@{]}"');
is($deparse->coderef2text(sub{ print "foo@{-}" }),
q<{
    print "foo@-";
}>, 'no need to curly around to interpolate "@-"');

# Strict hints in %^H are mercilessly suppressed
$a =
  `$^X $path "-MO=Deparse" -e "use strict; print;" 2>&1`;
unlike($a, qr/BEGIN/,
    "Deparse does not emit strict hh hints");

# ambient_pragmas should not mess with strict settings.
SKIP: {
    skip "requires 5.11", 1 unless $] >= 5.011;
    eval q`
	BEGIN {
	    # Clear out all hints
	    %^H = ();
	    $^H = 0;
	    B::Deparse->new->ambient_pragmas(strict => 'all');
	}
	use 5.011;  # should enable strict
	ok !eval '$do_noT_create_a_variable_with_this_name = 1',
	  'ambient_pragmas do not mess with compiling scope';
   `;
}

# multiple statements on format lines
$a = `$^X $path "-MO=Deparse" -e "format =" -e "\@" -e "x();z()" -e. 2>&1`;
$a =~ s/-e syntax OK\n//g;
is($a, <<'EOCODH', 'multiple statements on format lines');
format STDOUT =
@
x(); z()
.
EOCODH

SKIP: {
    skip("Your perl was built without taint support", 1)
        unless $Config::Config{taint_support};

    is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path, '-T' ],
           prog => "format =\n\@\n\$;\n.\n"),
        <<~'EOCODM', '$; on format line';
        format STDOUT =
        @
        $;
        .
        EOCODM
}

is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse,-l', $path ],
           prog => "format =\n\@\n\$foo\n.\n"),
   <<'EOCODM', 'formats with -l';
format STDOUT =
@
$foo
.
EOCODM

is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
           prog => "{ my \$x; format =\n\@\n\$x\n.\n}"),
   <<'EOCODN', 'formats nested inside blocks';
{
    my $x;
    format STDOUT =
@
$x
.
}
EOCODN

# CORE::format
$a = readpipe qq`$^X $path "-MO=Deparse" -e "use feature q|:all|;`
             .qq` my sub format; CORE::format =" -e. 2>&1`;
like($a, qr/CORE::format/, 'CORE::format when lex format sub is in scope');

# literal big chars under 'use utf8'
is($deparse->coderef2text(sub{ use utf8; /€/; }),
'{
    /\x{20ac}/;
}',
"qr/euro/");

# STDERR when deparsing sub calls
# For a short while the output included 'While deparsing'
$a = `$^X $path "-MO=Deparse" -e "foo()" 2>&1`;
$a =~ s/-e syntax OK\n//g;
is($a, <<'EOCODI', 'no extra output when deparsing foo()');
foo();
EOCODI

# Sub calls compiled before importation
like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
             prog => 'BEGIN {
                       require Test::More;
                       Test::More::->import;
                       is(*foo, *foo)
                     }'),
     qr/&is\(/,
    'sub calls compiled before importation of prototype subs';

# [perl #121050] Prototypes with whitespace
is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
           prog => <<'EOCODO'),
sub _121050(\$ \$) { }
_121050($a,$b);
sub _121050empty( ) {}
() = _121050empty() + 1;
EOCODO
   <<'EOCODP', '[perl #121050] prototypes with whitespace';
sub _121050 (\$ \$) {
    
}
_121050 $a, $b;
sub _121050empty ( ) {
    
}
() = _121050empty + 1;
EOCODP

# CORE::no
$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
             .qq`"use feature q|:all|; my sub no; CORE::no less" 2>&1`;
like($a, qr/my sub no;\n.*CORE::no less;/s,
    'CORE::no after my sub no');

# CORE::use
$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
             .qq`"use feature q|:all|; my sub use; CORE::use less" 2>&1`;
like($a, qr/my sub use;\n.*CORE::use less;/s,
    'CORE::use after my sub use');

# CORE::__DATA__
$a = readpipe qq`$^X $path "-MO=Deparse" -Xe `
             .qq`"use feature q|:all|; my sub __DATA__; `
             .qq`CORE::__DATA__" 2>&1`;
like($a, qr/my sub __DATA__;\n.*CORE::__DATA__/s,
    'CORE::__DATA__ after my sub __DATA__');

# sub declarations
$a = readpipe qq`$^X $path "-MO=Deparse" -e "sub foo{}" 2>&1`;
like($a, qr/sub foo\s*\{\s+\}/, 'sub declarations');
like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
           prog => 'sub f($); sub f($){}'),
     qr/sub f\s*\(\$\)\s*\{\s*\}/,
    'predeclared prototyped subs';
like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
           prog => 'sub f($);
                    BEGIN { use builtin q-weaken-; weaken($_=\$::{f}) }'),
     qr/sub f\s*\(\$\)\s*;/,
    'prototyped stub with weak reference to the stash entry';
like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
           prog => 'sub f () { 42 }'),
     qr/sub f\s*\(\)\s*\{\s*42;\s*\}/,
    'constant perl sub declaration';

# BEGIN blocks
SKIP : {
    skip "BEGIN output is wrong on old perls", 1 if $] < 5.021006;
    my $prog = '
      BEGIN { pop }
      {
        BEGIN { pop }
        {
          no overloading;
          {
            BEGIN { pop }
            die
          }
        }
      }';
    $prog =~ s/\n//g;
    $a = readpipe qq`$^X $path "-MO=Deparse" -e "$prog" 2>&1`;
    $a =~ s/-e syntax OK\n//g;
    is($a, <<'EOCODJ', 'BEGIN blocks');
sub BEGIN {
    pop @ARGV;
}
{
    sub BEGIN {
        pop @ARGV;
    }
    {
        no overloading;
        {
            sub BEGIN {
                pop @ARGV;
            }
            die;
        }
    }
}
EOCODJ
}
is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ], prog => '
      {
        {
          die;
          BEGIN { pop }
        }
        BEGIN { pop }
      }
      BEGIN { pop }
  '), <<'EOCODL', 'BEGIN blocks at the end of their enclosing blocks';
{
    {
        die;
        sub BEGIN {
            pop @ARGV;
        }
    }
    sub BEGIN {
        pop @ARGV;
    }
}
sub BEGIN {
    pop @ARGV;
}
EOCODL

# BEGIN blocks should not be called __ANON__
like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
             prog => 'sub BEGIN { } CHECK { delete $::{BEGIN} }'),
     qr/sub BEGIN/, 'anonymised BEGIN';

# [perl #115066]
my $prog = 'use constant FOO => do { 1 }; no overloading; die';
$a = readpipe qq`$^X $path "-MO=-qq,Deparse" -e "$prog" 2>&1`;
is($a, <<'EOCODK', '[perl #115066] use statements accidentally nested');
use constant ('FOO', do {
    1
});
no overloading;
die;
EOCODK

# BEGIN blocks inside predeclared subs
like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
             prog => '
                 sub run_tests;
                 run_tests();
                 sub run_tests { BEGIN { } die }'),
     qr/sub run_tests \{\s*sub BEGIN/,
    'BEGIN block inside predeclared sub';

like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
             prog => 'package foo; use overload qr=>sub{}'),
     qr/package foo;\s*use overload/,
    'package, then use';

like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
             prog => 'use feature lexical_subs=>; my sub f;sub main::f{}'),
     qr/^sub main::f \{/m,
    'sub decl when lex sub is in scope';

like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
             prog => 'sub foo{foo()}'),
     qr/^sub foo \{\s+foo\(\)/m,
    'recursive sub';

like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
             prog => 'use feature lexical_subs=>state=>;
                      state sub sb5; sub { sub sb5 { } }'),
     qr/sub \{\s*\(\);\s*sub sb5 \{/m,
    'state sub in anon sub but declared outside';

is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
             prog => 'BEGIN { $::{f}=\!0 }'),
   "sub BEGIN {\n    \$main::{'f'} = \\!0;\n}\n",
   '&PL_sv_yes constant (used to croak)';

SKIP: {
    skip("Your perl was built without taint support", 1)
        unless $Config::Config{taint_support};
    is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path, '-T' ],
           prog => '$x =~ (1?/$a/:0)'),
        '$x =~ ($_ =~ /$a/);'."\n",
        '$foo =~ <branch-folded match> under taint mode';
}

unlike runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path, '-w' ],
               prog => 'BEGIN { undef &foo }'),
       qr'Use of uninitialized value',
      'no warnings for undefined sub';

is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
    prog => 'sub f { 1; } BEGIN { *g = \&f; }'),
    "sub f {\n    1;\n}\nsub BEGIN {\n    *g = \\&f;\n}\n",
    "sub glob alias shouldn't impede emitting original sub";

is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
    prog => 'package Foo; sub f { 1; } BEGIN { *g = \&f; }'),
    "package Foo;\nsub f {\n    1;\n}\nsub BEGIN {\n    *g = \\&f;\n}\n",
    "sub glob alias outside main shouldn't impede emitting original sub";

is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
    prog => 'package Foo; sub f { 1; } BEGIN { *Bar::f = \&f; }'),
    "package Foo;\nsub f {\n    1;\n}\nsub BEGIN {\n    *Bar::f = \\&f;\n}\n",
    "sub glob alias in separate package shouldn't impede emitting original sub";


done_testing($tests);

__DATA__
# [perl #120950] Previously on a 2nd instance succeeded
# y/uni/code/
tr/\x{345}/\x{370}/;
####
# y/uni/code/  [perl #120950] This 2nd instance succeeds
tr/\x{345}/\x{370}/;
####
# A constant
1;
####
# Constants in a block
# CONTEXT no warnings;
{
    '???';
    2;
}
####
# List of constants in void context
# CONTEXT no warnings;
(1,2,3);
0;
>>>>
'???', '???', '???';
0;
####
# Lexical and simple arithmetic
my $test;
++$test and $test /= 2;
>>>>
my $test;
$test /= 2 if ++$test;
####
# list x
-((1, 2) x 2);
####
# Assignment to list x
((undef) x 3) = undef;
####
# lvalue sub
{
    my $test = sub : lvalue {
	my $x;
    }
    ;
}
####
# method
{
    my $test = sub : method {
	my $x;
    }
    ;
}
####
# anonsub attrs at statement start
my $x = do { +sub : lvalue { my $y; } };
my $z = do { foo: +sub : method { my $a; } };
####
# block with continue
{
    234;
}
continue {
    123;
}
####
# lexical and package scalars
my $x;
print $main::x;
####
# lexical and package arrays
my @x;
print $main::x[1];
print \my @a;
####
# lexical and package hashes
my %x;
$x{warn()};
####
# our (LIST)
our($foo, $bar, $baz);
####
# CONTEXT { package Dog } use feature "state";
# variables with declared classes
my Dog $spot;
our Dog $spotty;
state Dog $spotted;
my Dog @spot;
our Dog @spotty;
state Dog @spotted;
my Dog %spot;
our Dog %spotty;
state Dog %spotted;
my Dog ($foo, @bar, %baz);
our Dog ($phoo, @barr, %bazz);
state Dog ($fough, @barre, %bazze);
####
# local our
local our $rhubarb;
local our($rhu, $barb);
####
# <>
my $foo;
$_ .= <> . <ARGV> . <$foo>;
<$foo>;
<${foo}>;
<$ foo>;
>>>>
my $foo;
$_ .= readline(ARGV) . readline(ARGV) . readline($foo);
readline $foo;
glob $foo;
glob $foo;
####
# more <>
no warnings;
no strict;
my $fh;
if (dummy_sub < $fh > /bar/g) { 1 }
>>>>
no warnings;
no strict;
my $fh;
if (dummy_sub(glob((' ' . $fh . ' ')) / 'bar' / 'g')) {
    1;
}
####
# readline
readline 'FH';
readline *$_;
readline *{$_};
readline ${"a"};
>>>>
readline 'FH';
readline *$_;
readline *{$_;};
readline ${'a';};
####
# <<>>
$_ = <<>>;
####
# \x{}
my $foo = "Ab\x{100}\200\x{200}\237Cd\000Ef\x{1000}\cA\x{2000}\cZ";
my $bar = "\x{100}";
####
# Latin-1 chars
# TODO ? ord("A") != 65 && "EBCDIC"
my $baz = "B\366\x{100}";
my $bba = qr/B\366\x{100}/;
####
# s///e
s/x/'y';/e;
s/x/$a;/e;
s/x/complex_expression();/e;
####
# block
{ my $x; }
####
# while 1
while (1) { my $k; }
####
# trailing for
my ($x,@a);
$x=1 for @a;
>>>>
my($x, @a);
$x = 1 foreach (@a);
####
# 2 arguments in a 3 argument for
for (my $i = 0; $i < 2;) {
    my $z = 1;
}
####
# 3 argument for
for (my $i = 0; $i < 2; ++$i) {
    my $z = 1;
}
####
# 3 argument for again
for (my $i = 0; $i < 2; ++$i) {
    my $z = 1;
}
####
# 3-argument for with inverted condition
for (my $i; not $i;) {
    die;
}
for (my $i; not $i; ++$i) {
    die;
}
for (my $a; not +($1 || 2) ** 2;) {
    die;
}
Something_to_put_the_loop_in_void_context();
####
# while/continue
my $i;
while ($i) { my $z = 1; } continue { $i = 99; }
####
# foreach with my
foreach my $i (1, 2) {
    my $z = 1;
}
####
# OPTIONS -p
# foreach with my under -p
foreach my $i (1) {
    die;
}
####
# foreach
my $i;
foreach $i (1, 2) {
    my $z = 1;
}
####
# foreach, 2 mys
my $i;
foreach my $i (1, 2) {
    my $z = 1;
}
####
# foreach with our
foreach our $i (1, 2) {
    my $z = 1;
}
####
# foreach with my and our
my $i;
foreach our $i (1, 2) {
    my $z = 1;
}
####
# foreach with state
# CONTEXT use feature "state";
foreach state $i (1, 2) {
    state $z = 1;
}
####
# foreach with sub call
foreach $_ (hcaerof()) {
    ();
}
####
# reverse sort
my @x;
print reverse sort(@x);
####
# sort with cmp
my @x;
print((sort {$b cmp $a} @x));
####
# reverse sort with block
my @x;
print((reverse sort {$b <=> $a} @x));
####
# foreach reverse
our @a;
print $_ foreach (reverse @a);
####
# foreach reverse (not inplace)
our @a;
print $_ foreach (reverse 1, 2..5);
####
# bug #38684
our @ary;
@ary = split(' ', 'foo', 0);
####
my @ary;
@ary = split(' ', 'foo', 0);
####
# Split to our array
our @array = split(//, 'foo', 0);
####
# Split to my array
my @array  = split(//, 'foo', 0);
####
our @array;
my $c;
@array = split(/x(?{ $c++; })y/, 'foo', 0);
####
my($x, $y, $p);
our $c;
($x, $y) = split(/$p(?{ $c++; })y/, 'foo', 2);
####
our @ary;
my $pat;
@ary = split(/$pat/, 'foo', 0);
####
my @ary;
our $pat;
@ary = split(/$pat/, 'foo', 0);
####
our @array;
my $pat;
local @array = split(/$pat/, 'foo', 0);
####
our $pat;
my @array  = split(/$pat/, 'foo', 0);
####
# bug #40055
do { () }; 
####
# bug #40055
do { my $x = 1; $x }; 
####
# <20061012113037.GJ25805@c4.convolution.nl>
my $f = sub {
    +{[]};
} ;
####
# anonconst
# CONTEXT no warnings 'experimental::const_attr';
my $f = sub : const {
    123;
}
;
####
# bug #43010
'!@$%'->();
####
# bug #43010
::();
####
# bug #43010
'::::'->();
####
# bug #43010
&::::;
####
# [perl #77172]
package rt77172;
sub foo {} foo & & & foo;
>>>>
package rt77172;
foo(&{&} & foo());
####
# variables as method names
my $bar;
'Foo'->$bar('orz');
'Foo'->$bar('orz') = 'a stranger stranger than before';
####
# constants as method names
'Foo'->bar('orz');
####
# constants as method names without ()
'Foo'->bar;
####
# [perl #47359] "indirect" method call notation
our @bar;
foo{@bar}+1,->foo;
(foo{@bar}+1),foo();
foo{@bar}1 xor foo();
>>>>
our @bar;
(foo { @bar } 1)->foo;
(foo { @bar } 1), foo();
foo { @bar } 1 xor foo();
####
# indirops with blocks
# CONTEXT use 5.01;
print {*STDOUT;} 'foo';
printf {*STDOUT;} 'foo';
say {*STDOUT;} 'foo';
system {'foo';} '-foo';
exec {'foo';} '-foo';
####
# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
# CONTEXT use feature ':5.10';
# say
say 'foo';
####
# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
# CONTEXT use 5.10.0;
# say in the context of use 5.10.0
say 'foo';
####
# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
# say with use 5.10.0
use 5.10.0;
say 'foo';
>>>>
no feature ':all';
use feature ':5.10';
say 'foo';
####
# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
# say with use feature ':5.10';
use feature ':5.10';
say 'foo';
>>>>
use feature 'say', 'state', 'switch';
say 'foo';
####
# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
# CONTEXT use feature ':5.10';
# say with use 5.10.0 in the context of use feature
use 5.10.0;
say 'foo';
>>>>
no feature ':all';
use feature ':5.10';
say 'foo';
####
# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
# CONTEXT use 5.10.0;
# say with use feature ':5.10' in the context of use 5.10.0
use feature ':5.10';
say 'foo';
>>>>
say 'foo';
####
# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
# CONTEXT use feature ':5.15';
# __SUB__
__SUB__;
####
# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
# CONTEXT use 5.15.0;
# __SUB__ in the context of use 5.15.0
__SUB__;
####
# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
# __SUB__ with use 5.15.0
use 5.15.0;
__SUB__;
>>>>
no feature ':all';
use feature ':5.16';
__SUB__;
####
# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
# __SUB__ with use feature ':5.15';
use feature ':5.15';
__SUB__;
>>>>
use feature 'current_sub', 'evalbytes', 'fc', 'say', 'state', 'switch', 'unicode_strings', 'unicode_eval';
__SUB__;
####
# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
# CONTEXT use feature ':5.15';
# __SUB__ with use 5.15.0 in the context of use feature
use 5.15.0;
__SUB__;
>>>>
no feature ':all';
use feature ':5.16';
__SUB__;
####
# SKIP ?$] < 5.015 && "__SUB__ not implemented on this Perl version"
# CONTEXT use 5.15.0;
# __SUB__ with use feature ':5.15' in the context of use 5.15.0
use feature ':5.15';
__SUB__;
>>>>
__SUB__;
####
# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
# CONTEXT use feature ':5.10';
# state vars
state $x = 42;
####
# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
# CONTEXT use feature ':5.10';
# state var assignment
{
    my $y = (state $x = 42);
}
####
# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
# CONTEXT use feature ':5.10';
# state vars in anonymous subroutines
$a = sub {
    state $x;
    return $x++;
}
;
####
# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
# each @array;
each @ARGV;
each @$a;
####
# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
# keys @array; values @array
keys @$a if keys @ARGV;
values @ARGV if values @$a;
####
# Anonymous arrays and hashes, and references to them
my $a = {};
my $b = \{};
my $c = [];
my $d = \[];
####
# SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
# CONTEXT use feature ':5.10'; no warnings 'deprecated';
# implicit smartmatch in given/when
given ('foo') {
    when ('bar') { continue; }
    when ($_ ~~ 'quux') { continue; }
    default { 0; }
}
####
# conditions in elsifs (regression in change #33710 which fixed bug #37302)
if ($a) { x(); }
elsif ($b) { x(); }
elsif ($a and $b) { x(); }
elsif ($a or $b) { x(); }
else { x(); }
####
# interpolation in regexps
my($y, $t);
/x${y}z$t/;
####
# TODO new undocumented cpan-bug #33708
# cpan-bug #33708
%{$_ || {}}
####
# TODO hash constants not yet fixed
# cpan-bug #33708
use constant H => { "#" => 1 }; H->{"#"}
####
# TODO optimized away 0 not yet fixed
# cpan-bug #33708
foreach my $i (@_) { 0 }
####
# tests with not, not optimized
my $c;
x() unless $a;
x() if not $a and $b;
x() if $a and not $b;
x() unless not $a and $b;
x() unless $a and not $b;
x() if not $a or $b;
x() if $a or not $b;
x() unless not $a or $b;
x() unless $a or not $b;
x() if $a and not $b and $c;
x() if not $a and $b and not $c;
x() unless $a and not $b and $c;
x() unless not $a and $b and not $c;
x() if $a or not $b or $c;
x() if not $a or $b or not $c;
x() unless $a or not $b or $c;
x() unless not $a or $b or not $c;
####
# tests with not, optimized
my $c;
x() if not $a;
x() unless not $a;
x() if not $a and not $b;
x() unless not $a and not $b;
x() if not $a or not $b;
x() unless not $a or not $b;
x() if not $a and not $b and $c;
x() unless not $a and not $b and $c;
x() if not $a or not $b or $c;
x() unless not $a or not $b or $c;
x() if not $a and not $b and not $c;
x() unless not $a and not $b and not $c;
x() if not $a or not $b or not $c;
x() unless not $a or not $b or not $c;
x() unless not $a or not $b or not $c;
>>>>
my $c;
x() unless $a;
x() if $a;
x() unless $a or $b;
x() if $a or $b;
x() unless $a and $b;
x() if $a and $b;
x() if not $a || $b and $c;
x() unless not $a || $b and $c;
x() if not $a && $b or $c;
x() unless not $a && $b or $c;
x() unless $a or $b or $c;
x() if $a or $b or $c;
x() unless $a and $b and $c;
x() if $a and $b and $c;
x() unless not $a && $b && $c;
####
# tests that should be constant folded
x() if 1;
x() if GLIPP;
x() if !GLIPP;
x() if GLIPP && GLIPP;
x() if !GLIPP || GLIPP;
x() if do { GLIPP };
x() if do { no warnings 'void'; 5; GLIPP };
x() if do { !GLIPP };
if (GLIPP) { x() } else { z() }
if (!GLIPP) { x() } else { z() }
if (GLIPP) { x() } elsif (GLIPP) { z() }
if (!GLIPP) { x() } elsif (GLIPP) { z() }
if (GLIPP) { x() } elsif (!GLIPP) { z() }
if (!GLIPP) { x() } elsif (!GLIPP) { z() }
if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
>>>>
x();
x();
'???';
x();
x();
x();
x();
do {
    '???'
};
do {
    x()
};
do {
    z()
};
do {
    x()
};
do {
    z()
};
do {
    x()
};
'???';
do {
    t()
};
'???';
!1;
####
# TODO constant deparsing has been backed out for 5.12
# XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
# tests that shouldn't be constant folded
# It might be fundamentally impossible to make this work on ithreads, in which
# case the TODO should become a SKIP
x() if $a;
if ($a == 1) { x() } elsif ($b == 2) { z() }
if (do { foo(); GLIPP }) { x() }
if (do { $a++; GLIPP }) { x() }
>>>>
x() if $a;
if ($a == 1) { x(); } elsif ($b == 2) { z(); }
if (do { foo(); GLIPP }) { x(); }
if (do { ++$a; GLIPP }) { x(); }
####
# TODO constant deparsing has been backed out for 5.12
# tests for deparsing constants
warn PI;
####
# TODO constant deparsing has been backed out for 5.12
# tests for deparsing imported constants
warn O_TRUNC;
####
# TODO constant deparsing has been backed out for 5.12
# tests for deparsing re-exported constants
warn O_CREAT;
####
# TODO constant deparsing has been backed out for 5.12
# tests for deparsing imported constants that got deleted from the original namespace
warn O_APPEND;
####
# TODO constant deparsing has been backed out for 5.12
# XXXTODO ? $Config::Config{useithreads} && "doesn't work with threads"
# tests for deparsing constants which got turned into full typeglobs
# It might be fundamentally impossible to make this work on ithreads, in which
# case the TODO should become a SKIP
warn O_EXCL;
eval '@Fcntl::O_EXCL = qw/affe tiger/;';
warn O_EXCL;
####
# TODO constant deparsing has been backed out for 5.12
# tests for deparsing of blessed constant with overloaded numification
warn OVERLOADED_NUMIFICATION;
####
# strict
no strict;
print $x;
use strict 'vars';
print $main::x;
use strict 'subs';
print $main::x;
use strict 'refs';
print $main::x;
no strict 'vars';
$x;
####
# TODO Subsets of warnings could be encoded textually, rather than as bitflips.
# subsets of warnings
no warnings 'deprecated';
my $x;
####
# TODO Better test for CPAN #33708 - the deparsed code has different behaviour
# CPAN #33708
use strict;
no warnings;

foreach (0..3) {
    my $x = 2;
    {
	my $x if 0;
	print ++$x, "\n";
    }
}
####
# no attribute list
my $pi = 4;
####
# SKIP ?$] > 5.013006 && ":= is now a syntax error"
# := treated as an empty attribute list
no warnings;
my $pi := 4;
>>>>
no warnings;
my $pi = 4;
####
# : = empty attribute list
my $pi : = 4;
>>>>
my $pi = 4;
####
# in place sort
our @a;
my @b;
@a = sort @a;
@b = sort @b;
();
####
# in place reverse
our @a;
my @b;
@a = reverse @a;
@b = reverse @b;
();
####
# #71870 Use of uninitialized value in bitwise and B::Deparse
my($r, $s, @a);
@a = split(/foo/, $s, 0);
$r = qr/foo/;
@a = split(/$r/, $s, 0);
();
####
# package declaration before label
{
    package Foo;
    label: print 123;
}
####
# shift optimisation
shift;
>>>>
shift();
####
# shift optimisation
shift @_;
####
# shift optimisation
pop;
>>>>
pop();
####
# shift optimisation
pop @_;
####
#[perl #20444]
"foo" =~ (1 ? /foo/ : /bar/);
"foo" =~ (1 ? y/foo// : /bar/);
"foo" =~ (1 ? y/foo//r : /bar/);
"foo" =~ (1 ? s/foo// : /bar/);
>>>>
'foo' =~ ($_ =~ /foo/);
'foo' =~ ($_ =~ tr/fo//);
'foo' =~ ($_ =~ tr/fo//r);
'foo' =~ ($_ =~ s/foo//);
####
# The fix for [perl #20444] broke this.
'foo' =~ do { () };
####
# [perl #81424] match against aelemfast_lex
my @s;
print /$s[1]/;
####
# /$#a/
print /$#main::a/;
####
# /@array/
our @a;
my @b;
print /@a/;
print /@b/;
print qr/@a/;
print qr/@b/;
####
# =~ QR_CONSTANT
use constant QR_CONSTANT => qr/a/soupmix;
'' =~ QR_CONSTANT;
>>>>
'' =~ /a/impsux;
####
# $lexical =~ //
my $x;
$x =~ //;
####
# [perl #91318] /regexp/applaud
print /a/a, s/b/c/a;
print /a/aa, s/b/c/aa;
print /a/p, s/b/c/p;
print /a/l, s/b/c/l;
print /a/u, s/b/c/u;
{
    use feature "unicode_strings";
    print /a/d, s/b/c/d;
}
{
    use re "/u";
    print /a/d, s/b/c/d;
}
{
    use 5.012;
    print /a/d, s/b/c/d;
}
>>>>
print /a/a, s/b/c/a;
print /a/aa, s/b/c/aa;
print /a/p, s/b/c/p;
print /a/l, s/b/c/l;
print /a/u, s/b/c/u;
{
    use feature 'unicode_strings';
    print /a/d, s/b/c/d;
}
{
    BEGIN { $^H{'reflags'}         = '0';
	    $^H{'reflags_charset'} = '2'; }
    print /a/d, s/b/c/d;
}
{
    no feature ':all';
    use feature ':5.12';
    print /a/d, s/b/c/d;
}
####
# all the flags (qr//)
$_ = qr/X/m;
$_ = qr/X/s;
$_ = qr/X/i;
$_ = qr/X/x;
$_ = qr/X/p;
$_ = qr/X/o;
$_ = qr/X/u;
$_ = qr/X/a;
$_ = qr/X/l;
$_ = qr/X/n;
####
use feature 'unicode_strings';
$_ = qr/X/d;
####
# all the flags (m//)
/X/m;
/X/s;
/X/i;
/X/x;
/X/p;
/X/o;
/X/u;
/X/a;
/X/l;
/X/n;
/X/g;
/X/cg;
####
use feature 'unicode_strings';
/X/d;
####
# all the flags (s///)
s/X//m;
s/X//s;
s/X//i;
s/X//x;
s/X//p;
s/X//o;
s/X//u;
s/X//a;
s/X//l;
s/X//n;
s/X//g;
s/X/'';/e;
s/X//r;
####
use feature 'unicode_strings';
s/X//d;
####
# tr/// with all the flags: empty replacement
tr/B-G//;
tr/B-G//c;
tr/B-G//d;
tr/B-G//s;
tr/B-G//cd;
tr/B-G//ds;
tr/B-G//cs;
tr/B-G//cds;
tr/B-G//r;
####
# tr/// with all the flags: short replacement
tr/B-G/b/;
tr/B-G/b/c;
tr/B-G/b/d;
tr/B-G/b/s;
tr/B-G/b/cd;
tr/B-G/b/ds;
tr/B-G/b/cs;
tr/B-G/b/cds;
tr/B-G/b/r;
####
# tr/// with all the flags: equal length replacement
tr/B-G/b-g/;
tr/B-G/b-g/c;
tr/B-G/b-g/s;
tr/B-G/b-g/cs;
tr/B-G/b-g/r;
####
# tr with extended table (/c)
tr/\000-\375/AB/c;
tr/\000-\375/A-C/c;
tr/\000-\375/A-D/c;
tr/\000-\375/A-I/c;
tr/\000-\375/AB/cd;
tr/\000-\375/A-C/cd;
tr/\000-\375/A-D/cd;
tr/\000-\375/A-I/cd;
tr/\000-\375/AB/cds;
tr/\000-\375/A-C/cds;
tr/\000-\375/A-D/cds;
tr/\000-\375/A-I/cds;
####
# tr/// with all the flags: empty replacement
tr/\x{101}-\x{106}//;
tr/\x{101}-\x{106}//c;
tr/\x{101}-\x{106}//d;
tr/\x{101}-\x{106}//s;
tr/\x{101}-\x{106}//cd;
tr/\x{101}-\x{106}//ds;
tr/\x{101}-\x{106}//cs;
tr/\x{101}-\x{106}//cds;
tr/\x{101}-\x{106}//r;
####
# tr/// with all the flags: short replacement
tr/\x{101}-\x{106}/\x{111}/;
tr/\x{101}-\x{106}/\x{111}/c;
tr/\x{101}-\x{106}/\x{111}/d;
tr/\x{101}-\x{106}/\x{111}/s;
tr/\x{101}-\x{106}/\x{111}/cd;
tr/\x{101}-\x{106}/\x{111}/ds;
tr/\x{101}-\x{106}/\x{111}/cs;
tr/\x{101}-\x{106}/\x{111}/cds;
tr/\x{101}-\x{106}/\x{111}/r;
####
# tr/// with all the flags: equal length replacement
tr/\x{101}-\x{106}/\x{111}-\x{116}/;
tr/\x{101}-\x{106}/\x{111}-\x{116}/c;
tr/\x{101}-\x{106}/\x{111}-\x{116}/s;
tr/\x{101}-\x{106}/\x{111}-\x{116}/cs;
tr/\x{101}-\x{106}/\x{111}-\x{116}/r;
####
# tr across 255/256 boundary, complemented
tr/\cA-\x{100}/AB/c;
tr/\cA-\x{100}/A-C/c;
tr/\cA-\x{100}/A-D/c;
tr/\cA-\x{100}/A-I/c;
tr/\cA-\x{100}/AB/cd;
tr/\cA-\x{100}/A-C/cd;
tr/\cA-\x{100}/A-D/cd;
tr/\cA-\x{100}/A-I/cd;
tr/\cA-\x{100}/AB/cds;
tr/\cA-\x{100}/A-C/cds;
tr/\cA-\x{100}/A-D/cds;
tr/\cA-\x{100}/A-I/cds;
####
# [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns)
s/foo/\(3);/eg;
####
# [perl #115256]
"" =~ /a(?{ print q|
|})/;
>>>>
'' =~ /a(?{ print "\n"; })/;
####
# [perl #123217]
$_ = qr/(??{<<END})/
f.o
b.r
END
>>>>
$_ = qr/(??{ "f.o\nb.r\n"; })/;
####
# More regexp code block madness
my($b, @a);
/(?{ die $b; })/;
/a(?{ die $b; })a/;
/$a(?{ die $b; })/;
/@a(?{ die $b; })/;
/(??{ die $b; })/;
/a(??{ die $b; })a/;
/$a(??{ die $b; })/;
/@a(??{ die $b; })/;
qr/(?{ die $b; })/;
qr/a(?{ die $b; })a/;
qr/$a(?{ die $b; })/;
qr/@a(?{ die $b; })/;
qr/(??{ die $b; })/;
qr/a(??{ die $b; })a/;
qr/$a(??{ die $b; })/;
qr/@a(??{ die $b; })/;
s/(?{ die $b; })//;
s/a(?{ die $b; })a//;
s/$a(?{ die $b; })//;
s/@a(?{ die $b; })//;
s/(??{ die $b; })//;
s/a(??{ die $b; })a//;
s/$a(??{ die $b; })//;
s/@a(??{ die $b; })//;
####
# /(?x)<newline><tab>/
/(?x)
	/;
####
# y///r
tr/a/b/r + $a =~ tr/p/q/r;
####
# y///d in list [perl #119815]
() = tr/a//d;
####
# [perl #90898]
<a,>;
glob 'a,';
>>>>
glob 'a,';
glob 'a,';
####
# [perl #91008]
# SKIP ?$] >= 5.023 && "autoderef deleted in this Perl version"
# CONTEXT no warnings 'experimental::autoderef';
each $@;
keys $~;
values $!;
####
# readpipe with complex expression
readpipe $a + $b;
####
# aelemfast
$b::a[0] = 1;
####
# aelemfast for a lexical
my @a;
$a[0] = 1;
####
# feature features without feature
# CONTEXT no warnings 'deprecated';
CORE::state $x;
CORE::say $x;
CORE::given ($x) {
    CORE::when (3) {
        continue;
    }
    CORE::default {
        CORE::break;
    }
}
CORE::evalbytes '';
() = CORE::__SUB__;
() = CORE::fc $x;
####
# feature features when feature has been disabled by use VERSION
# CONTEXT no warnings 'deprecated';
use feature (sprintf(":%vd", $^V));
use 1;
CORE::say $_;
CORE::state $x;
CORE::given ($x) {
    CORE::when (3) {
        continue;
    }
    CORE::default {
        CORE::break;
    }
}
CORE::evalbytes '';
() = CORE::__SUB__;
>>>>
CORE::say $_;
CORE::state $x;
CORE::given ($x) {
    CORE::when (3) {
        continue;
    }
    CORE::default {
        CORE::break;
    }
}
CORE::evalbytes '';
() = CORE::__SUB__;
####
# (the above test with CONTEXT, and the output is equivalent but different)
# CONTEXT use feature ':5.10'; no warnings 'deprecated';
# feature features when feature has been disabled by use VERSION
use feature (sprintf(":%vd", $^V));
use 1;
CORE::say $_;
CORE::state $x;
CORE::given ($x) {
    CORE::when (3) {
        continue;
    }
    CORE::default {
        CORE::break;
    }
}
CORE::evalbytes '';
() = CORE::__SUB__;
>>>>
no feature ':all';
use feature ':default';
CORE::say $_;
CORE::state $x;
CORE::given ($x) {
    CORE::when (3) {
        continue;
    }
    CORE::default {
        CORE::break;
    }
}
CORE::evalbytes '';
() = CORE::__SUB__;
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
# lexical subroutines and keywords of the same name
# CONTEXT use feature 'lexical_subs', 'switch'; no warnings 'experimental'; no warnings 'deprecated';
my sub default;
my sub else;
my sub elsif;
my sub for;
my sub foreach;
my sub given;
my sub if;
my sub m;
my sub no;
my sub package;
my sub q;
my sub qq;
my sub qr;
my sub qx;
my sub require;
my sub s;
my sub sub;
my sub tr;
my sub unless;
my sub until;
my sub use;
my sub when;
my sub while;
CORE::default { die; }
CORE::if ($1) { die; }
CORE::if ($1) { die; }
CORE::elsif ($1) { die; }
CORE::else { die; }
CORE::for (die; $1; die) { die; }
CORE::foreach $_ (1 .. 10) { die; }
die CORE::foreach (1);
CORE::given ($1) { die; }
CORE::m[/];
CORE::m?/?;
CORE::package foo;
CORE::no strict;
() = (CORE::q['], CORE::qq["$_], CORE::qr//, CORE::qx[`]);
CORE::require 1;
CORE::s///;
() = CORE::sub { die; } ;
CORE::tr///;
CORE::unless ($1) { die; }
CORE::until ($1) { die; }
die CORE::until $1;
CORE::use strict;
CORE::when ($1 ~~ $2) { die; }
CORE::while ($1) { die; }
die CORE::while $1;
####
# Feature hints
use feature 'current_sub', 'evalbytes';
print;
use 1;
print;
use 5.014;
print;
no feature 'unicode_strings';
print;
>>>>
use feature 'current_sub', 'evalbytes';
print $_;
no feature ':all';
use feature ':default';
print $_;
no feature ':all';
use feature ':5.12';
print $_;
no feature 'unicode_strings';
print $_;
####
# $#- $#+ $#{%} etc.
my @x;
@x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*});
@x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,});
@x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-);
@x = ($#{;}, $#{:}, $#{1}), $#_;
####
# [perl #86060] $( $| $) in regexps need braces
/${(}/;
/${|}/;
/${)}/;
/${(}${|}${)}/;
/@{+}@{-}/;
####
# ()[...]
my(@a) = ()[()];
####
# sort(foo(bar))
# sort(foo(bar)) is interpreted as sort &foo(bar)
# sort foo(bar) is interpreted as sort foo bar
# parentheses are not optional in this case
print sort(foo('bar'));
>>>>
print sort(foo('bar'));
####
# substr assignment
substr(my $a, 0, 0) = (foo(), bar());
$a++;
####
# This following line works around an unfixed bug that we are not trying to 
# test for here:
# CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
# hint hash
BEGIN { $^H{'foo'} = undef; }
{
 BEGIN { $^H{'bar'} = undef; }
 {
  BEGIN { $^H{'baz'} = undef; }
  {
   print $_;
  }
  print $_;
 }
 print $_;
}
BEGIN { $^H{q[']} = '('; }
print $_;
####
# This following line works around an unfixed bug that we are not trying to 
# test for here:
# CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
# hint hash changes that serialise the same way with sort %hh
BEGIN { $^H{'a'} = 'b'; }
{
 BEGIN { $^H{'b'} = 'a'; delete $^H{'a'}; }
 print $_;
}
print $_;
####
# [perl #47361] do({}) and do +{} (variants of do-file)
do({});
do +{};
sub foo::do {}
package foo;
CORE::do({});
CORE::do +{};
>>>>
do({});
do({});
package foo;
CORE::do({});
CORE::do({});
####
# [perl #77096] functions that do not follow the looks-like-a-function rule
() = (return 1) + time;
() = (return ($1 + $2) * $3) + time;
() = (return ($a xor $b)) + time;
() = (do 'file') + time;
() = (do ($1 + $2) * $3) + time;
() = (do ($1 xor $2)) + time;
() = (goto 1) + 3;
() = (require 'foo') + 3;
() = (require foo) + 3;
() = (CORE::dump 1) + 3;
() = (last 1) + 3;
() = (next 1) + 3;
() = (redo 1) + 3;
() = (-R $_) + 3;
() = (-W $_) + 3;
() = (-X $_) + 3;
() = (-r $_) + 3;
() = (-w $_) + 3;
() = (-x $_) + 3;
>>>>
() = (return 1);
() = (return ($1 + $2) * $3);
() = (return ($a xor $b));
() = (do 'file') + time;
() = (do ($1 + $2) * $3) + time;
() = (do ($1 xor $2)) + time;
() = (goto 1);
() = (require 'foo') + 3;
() = (require foo) + 3;
() = (CORE::dump 1);
() = (last 1);
() = (next 1);
() = (redo 1);
() = (-R $_) + 3;
() = (-W $_) + 3;
() = (-X $_) + 3;
() = (-r $_) + 3;
() = (-w $_) + 3;
() = (-x $_) + 3;
####
# require(foo()) and do(foo())
require (foo());
do (foo());
goto (foo());
CORE::dump (foo());
last (foo());
next (foo());
redo (foo());
####
# require vstring
require v5.16;
####
# [perl #97476] not() *does* follow the llafr
$_ = ($a xor not +($1 || 2) ** 2);
####
# Precedence conundrums with argument-less function calls
() = (eof) + 1;
() = (return) + 1;
() = (return, 1);
() = warn;
() = warn() + 1;
() = setpgrp() + 1;
>>>>
() = (eof) + 1;
() = (return);
() = (return, 1);
() = warn;
() = warn() + 1;
() = setpgrp() + 1;
####
# loopexes have assignment prec
() = (CORE::dump a) | 'b';
() = (goto a) | 'b';
() = (last a) | 'b';
() = (next a) | 'b';
() = (redo a) | 'b';
>>>>
() = (CORE::dump a);
() = (goto a);
() = (last a);
() = (next a);
() = (redo a);
####
# [perl #63558] open local(*FH)
open local *FH;
pipe local *FH, local *FH;
####
# [perl #91416] open "string"
open 'open';
open '####';
open '^A';
open "\ca";
>>>>
open *open;
open '####';
open '^A';
open *^A;
####
# "string"->[] ->{}
no strict 'vars';
() = 'open'->[0]; #aelemfast
() = '####'->[0];
() = '^A'->[0];
() = "\ca"->[0];
() = 'a::]b'->[0];
() = 'open'->[$_]; #aelem
() = '####'->[$_];
() = '^A'->[$_];
() = "\ca"->[$_];
() = 'a::]b'->[$_];
() = 'open'->{0}; #helem
() = '####'->{0};
() = '^A'->{0};
() = "\ca"->{0};
() = 'a::]b'->{0};
>>>>
no strict 'vars';
() = $open[0];
() = '####'->[0];
() = '^A'->[0];
() = $^A[0];
() = 'a::]b'->[0];
() = $open[$_];
() = '####'->[$_];
() = '^A'->[$_];
() = $^A[$_];
() = 'a::]b'->[$_];
() = $open{'0'};
() = '####'->{'0'};
() = '^A'->{'0'};
() = $^A{'0'};
() = 'a::]b'->{'0'};
####
# [perl #74740] -(f()) vs -f()
$_ = -(f());
####
# require <binop>
require 'a' . $1;
####
#[perl #30504] foreach-my postfix/prefix difference
$_ = 'foo' foreach my ($foo1, $bar1, $baz1);
foreach (my ($foo2, $bar2, $baz2)) { $_ = 'foo' }
foreach my $i (my ($foo3, $bar3, $baz3)) { $i = 'foo' }
>>>>
$_ = 'foo' foreach (my($foo1, $bar1, $baz1));
foreach $_ (my($foo2, $bar2, $baz2)) {
    $_ = 'foo';
}
foreach my $i (my($foo3, $bar3, $baz3)) {
    $i = 'foo';
}
####
#[perl #108224] foreach with continue block
foreach (1 .. 3) { print } continue { print "\n" }
foreach (1 .. 3) { } continue { }
foreach my $i (1 .. 3) { print $i } continue { print "\n" }
foreach my $i (1 .. 3) { } continue { }
>>>>
foreach $_ (1 .. 3) {
    print $_;
}
continue {
    print "\n";
}
foreach $_ (1 .. 3) {
    ();
}
continue {
    ();
}
foreach my $i (1 .. 3) {
    print $i;
}
continue {
    print "\n";
}
foreach my $i (1 .. 3) {
    ();
}
continue {
    ();
}
####
# file handles
no strict;
my $mfh;
open F;
open *F;
open $fh;
open $mfh;
open 'a+b';
select *F;
select F;
select $f;
select $mfh;
select 'a+b';
####
# 'my' works with padrange op
my($z, @z);
my $m1;
$m1 = 1;
$z = $m1;
my $m2 = 2;
my($m3, $m4);
($m3, $m4) = (1, 2);
@z = ($m3, $m4);
my($m5, $m6) = (1, 2);
my($m7, undef, $m8) = (1, 2, 3);
@z = ($m7, undef, $m8);
($m7, undef, $m8) = (1, 2, 3);
####
# 'our/local' works with padrange op
our($z, @z);
our $o1;
no strict;
local $o11;
$o1 = 1;
local $o1 = 1;
$z = $o1;
$z = local $o1;
our $o2 = 2;
our($o3, $o4);
($o3, $o4) = (1, 2);
local($o3, $o4) = (1, 2);
@z = ($o3, $o4);
@z = local($o3, $o4);
our($o5, $o6) = (1, 2);
our($o7, undef, $o8) = (1, 2, 3);
@z = ($o7, undef, $o8);
@z = local($o7, undef, $o8);
($o7, undef, $o8) = (1, 2, 3);
local($o7, undef, $o8) = (1, 2, 3);
####
# 'state' works with padrange op
# CONTEXT no strict; use feature 'state';
state($z, @z);
state $s1;
$s1 = 1;
$z = $s1;
state $s2 = 2;
state($s3, $s4);
($s3, $s4) = (1, 2);
@z = ($s3, $s4);
# assignment of state lists isn't implemented yet
#state($s5, $s6) = (1, 2);
#state($s7, undef, $s8) = (1, 2, 3);
#@z = ($s7, undef, $s8);
($s7, undef, $s8) = (1, 2, 3);
####
# anon arrays with padrange
my($a, $b);
my $c = [$a, $b];
my $d = {$a, $b};
####
# slices with padrange
my($a, $b);
my(@x, %y);
@x = @x[$a, $b];
@x = @y{$a, $b};
####
# binops with padrange
my($a, $b, $c);
$c = $a cmp $b;
$c = $a + $b;
$a += $b;
$c = $a - $b;
$a -= $b;
$c = my $a1 cmp $b;
$c = my $a2 + $b;
$a += my $b1;
$c = my $a3 - $b;
$a -= my $b2;
####
# 'x' with padrange
my($a, $b, $c, $d, @e);
$c = $a x $b;
$a x= $b;
@e = ($a) x $d;
@e = ($a, $b) x $d;
@e = ($a, $b, $c) x $d;
@e = ($a, 1) x $d;
####
# @_ with padrange
my($a, $b, $c) = @_;
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
# lexical subroutine
# CONTEXT use feature 'lexical_subs';
no warnings "experimental::lexical_subs";
my sub f {}
print f();
>>>>
my sub f {
    
}
print f();
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
# lexical "state" subroutine
# CONTEXT use feature 'state', 'lexical_subs';
no warnings 'experimental::lexical_subs';
state sub f {}
print f();
>>>>
state sub f {
    
}
print f();
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
# lexical subroutine scoping
# CONTEXT use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
{
  {
    my sub a { die; }
    {
      foo();
      my sub b;
      b;
      main::b();
      &main::b;
      &main::b();
      my $b = \&main::b;
      sub b { $b; }
    }
  }
  b();
}
####
# self-referential lexical subroutine
# CONTEXT use feature 'lexical_subs', 'state'; no warnings 'experimental::lexical_subs';
();
state sub sb2;
sub sb2 {
    sb2;
}
####
# lexical subroutine with outer declaration and inner definition
# CONTEXT use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
();
my sub f;
my sub g {
    ();
    sub f { }
}
####
# lexical state subroutine with outer declaration and inner definition
# CONTEXT use feature 'lexical_subs', 'state'; no warnings 'experimental::lexical_subs';
();
state sub sb4;
state sub a {
    ();
    sub sb4 { }
}
state sub sb5;
sub {
    ();
    sub sb5 { }
} ;
####
# Elements of %# should not be confused with $#{ array }
() = ${#}{'foo'};
####
# $; [perl #123357]
$_ = $;;
do {
    $;
};
####
# Ampersand calls and scalar context
# OPTIONS -P
package prototest;
sub foo($$);
foo(bar(),baz());
>>>>
package prototest;
&foo(scalar bar(), scalar baz());
####
# coderef2text and prototyped sub calls [perl #123435]
is 'foo', 'oo';
####
# prototypes with unary precedence
package prototest;
sub dollar($) {}
sub optdollar(;$) {}
sub optoptdollar(;;$) {}
sub splat(*) {}
sub optsplat(;*) {}
sub optoptsplat(;;*) {}
sub bar(_) {}
sub optbar(;_) {}
sub optoptbar(;;_) {}
sub plus(+) {}
sub optplus(;+) {}
sub optoptplus(;;+) {}
sub wack(\$) {}
sub optwack(;\$) {}
sub optoptwack(;;\$) {}
sub wackbrack(\[$]) {}
sub optwackbrack(;\[$]) {}
sub optoptwackbrack(;;\[$]) {}
dollar($a < $b);
optdollar($a < $b);
optoptdollar($a < $b);
splat($a < $b);     # Some of these deparse with ‘&’; if that changes, just
optsplat($a < $b);  # change the tests.
optoptsplat($a < $b);
bar($a < $b);
optbar($a < $b);
optoptbar($a < $b);
plus($a < $b);
optplus($a < $b);
optoptplus($a < $b);
wack($a = $b);
optwack($a = $b);
optoptwack($a = $b);
wackbrack($a = $b);
optwackbrack($a = $b);
optoptwackbrack($a = $b);
optbar;
optoptbar;
optplus;
optoptplus;
optwack;
optoptwack;
optwackbrack;
optoptwackbrack;
>>>>
package prototest;
dollar($a < $b);
optdollar($a < $b);
optoptdollar($a < $b);
&splat($a < $b);
&optsplat($a < $b);
&optoptsplat($a < $b);
bar($a < $b);
optbar($a < $b);
optoptbar($a < $b);
plus($a < $b);
optplus($a < $b);
optoptplus($a < $b);
&wack(\($a = $b));
&optwack(\($a = $b));
&optoptwack(\($a = $b));
&wackbrack(\($a = $b));
&optwackbrack(\($a = $b));
&optoptwackbrack(\($a = $b));
optbar;
optoptbar;
optplus;
optoptplus;
optwack;
optoptwack;
optwackbrack;
optoptwackbrack;
####
# enreferencing prototypes: @
# CONTEXT sub wackat(\@) {} sub optwackat(;\@) {} sub wackbrackat(\[@]) {} sub optwackbrackat(;\[@]) {}
wackat(my @a0);
wackat(@a0);
wackat(@ARGV);
wackat(@{['t'];});
optwackat;
optwackat(my @a1);
optwackat(@a1);
optwackat(@ARGV);
optwackat(@{['t'];});
wackbrackat(my @a2);
wackbrackat(@a2);
wackbrackat(@ARGV);
wackbrackat(@{['t'];});
optwackbrackat;
optwackbrackat(my @a3);
optwackbrackat(@a3);
optwackbrackat(@ARGV);
optwackbrackat(@{['t'];});
####
# enreferencing prototypes: %
# CONTEXT sub wackperc(\%) {} sub optwackperc(;\%) {} sub wackbrackperc(\[%]) {} sub optwackbrackperc(;\[%]) {}
wackperc(my %a0);
wackperc(%a0);
wackperc(%ARGV);
wackperc(%{+{'t', 1};});
optwackperc;
optwackperc(my %a1);
optwackperc(%a1);
optwackperc(%ARGV);
optwackperc(%{+{'t', 1};});
wackbrackperc(my %a2);
wackbrackperc(%a2);
wackbrackperc(%ARGV);
wackbrackperc(%{+{'t', 1};});
optwackbrackperc;
optwackbrackperc(my %a3);
optwackbrackperc(%a3);
optwackbrackperc(%ARGV);
optwackbrackperc(%{+{'t', 1};});
####
# enreferencing prototypes: +
# CONTEXT sub plus(+) {} sub optplus(;+) {}
plus('hi');
plus(my @a0);
plus(my %h0);
plus(\@a0);
plus(\%h0);
optplus;
optplus('hi');
optplus(my @a1);
optplus(my %h1);
optplus(\@a1);
optplus(\%h1);
>>>>
plus('hi');
plus(my @a0);
plus(my %h0);
plus(@a0);
plus(%h0);
optplus;
optplus('hi');
optplus(my @a1);
optplus(my %h1);
optplus(@a1);
optplus(%h1);
####
# ensure aelemfast works in the range -128..127 and that there's no
# funky edge cases
my $x;
no strict 'vars';
$x = $a[-256] + $a[-255] + $a[-129] + $a[-128] + $a[-127] + $a[-1] + $a[0];
$x = $a[1] + $a[126] + $a[127] + $a[128] + $a[255] + $a[256];
my @b;
$x = $b[-256] + $b[-255] + $b[-129] + $b[-128] + $b[-127] + $b[-1] + $b[0];
$x = $b[1] + $b[126] + $b[127] + $b[128] + $b[255] + $b[256];
####
# 'm' must be preserved in m??
m??;
####
# \(@array) and \(..., (@array), ...)
my(@array, %hash, @a, @b, %c, %d);
() = \(@array);
() = \(%hash);
() = \(@a, (@b), (%c), %d);
() = \(@Foo::array);
() = \(%Foo::hash);
() = \(@Foo::a, (@Foo::b), (%Foo::c), %Foo::d);
####
# subs synonymous with keywords
main::our();
main::pop();
state();
use feature 'state';
main::state();
####
# lvalue references
# CONTEXT use feature "state", 'refaliasing', 'lexical_subs'; no warnings 'experimental';
our $x;
\$x = \$x;
my $m;
\$m = \$x;
\my $n = \$x;
(\$x) = @_;
\($x) = @_;
\($m) = @_;
(\$m) = @_;
\my($p) = @_;
(\my $r) = @_;
\($x, my $a) = @{[\$x, \$x]};
(\$x, \my $b) = @{[\$x, \$x]};
\local $x = \3;
\local($x) = \3;
\state $c = \3;
\state($d) = \3;
\our $e = \3;
\our($f) = \3;
\$_[0] = foo();
\($_[1]) = foo();
my @a;
\$a[0] = foo();
\($a[1]) = foo();
\local($a[1]) = foo();
\@a[0,1] = foo();
\(@a[2,3]) = foo();
\local @a[0,1] = (\$a)x2;
\$_{a} = foo();
\($_{b}) = foo();
my %h;
\$h{a} = foo();
\($h{b}) = foo();
\local $h{a} = \$x;
\local($h{b}) = \$x;
\@h{'a','b'} = foo();
\(@h{2,3}) = foo();
\local @h{'a','b'} = (\$x)x2;
\@_ = foo();
\@a = foo();
(\@_) = foo();
(\@a) = foo();
\my @c = foo();
(\my @d) = foo();
\(@_) = foo();
\(@a) = foo();
\my(@g) = foo();
\local @_ = \@_;
(\local @_) = \@_;
\state @e = [1..3];
\state(@f) = \3;
\our @i = [1..3];
\our(@h) = \3;
\%_ = foo();
\%h = foo();
(\%_) = foo();
(\%h) = foo();
\my %c = foo();
(\my %d) = foo();
\local %_ = \%h;
(\local %_) = \%h;
\state %y = {1,2};
\our %z = {1,2};
(\our %zz) = {1,2};
\&a = foo();
(\&a) = foo();
\(&a) = foo();
{
  my sub a;
  \&a = foo();
  (\&a) = foo();
  \(&a) = foo();
}
(\$_, $_) = \(1, 2);
$_ == 3 ? \$_ : $_ = \3;
$_ == 3 ? \$_ : \$x = \3;
\($_ == 3 ? $_ : $x) = \3;
for \my $topic (\$1, \$2) {
    die;
}
for \state $topic (\$1, \$2) {
    die;
}
for \our $topic (\$1, \$2) {
    die;
}
for \$_ (\$1, \$2) {
    die;
}
for \my @a ([1,2], [3,4]) {
    die;
}
for \state @a ([1,2], [3,4]) {
    die;
}
for \our @a ([1,2], [3,4]) {
    die;
}
for \@_ ([1,2], [3,4]) {
    die;
}
for \my %a ({5,6}, {7,8}) {
    die;
}
for \our %a ({5,6}, {7,8}) {
    die;
}
for \state %a ({5,6}, {7,8}) {
    die;
}
for \%_ ({5,6}, {7,8}) {
    die;
}
{
    my sub a;
    for \&a (sub { 9; }, sub { 10; }) {
        die;
    }
}
for \&a (sub { 9; }, sub { 10; }) {
    die;
}
>>>>
our $x;
\$x = \$x;
my $m;
\$m = \$x;
\my $n = \$x;
(\$x) = @_;
(\$x) = @_;
(\$m) = @_;
(\$m) = @_;
(\my $p) = @_;
(\my $r) = @_;
(\$x, \my $a) = @{[\$x, \$x];};
(\$x, \my $b) = @{[\$x, \$x];};
\local $x = \3;
(\local $x) = \3;
\state $c = \3;
(\state $d) = \3;
\our $e = \3;
(\our $f) = \3;
\$_[0] = foo();
(\$_[1]) = foo();
my @a;
\$a[0] = foo();
(\$a[1]) = foo();
(\local $a[1]) = foo();
(\@a[0, 1]) = foo();
(\@a[2, 3]) = foo();
(\local @a[0, 1]) = (\$a) x 2;
\$_{'a'} = foo();
(\$_{'b'}) = foo();
my %h;
\$h{'a'} = foo();
(\$h{'b'}) = foo();
\local $h{'a'} = \$x;
(\local $h{'b'}) = \$x;
(\@h{'a', 'b'}) = foo();
(\@h{2, 3}) = foo();
(\local @h{'a', 'b'}) = (\$x) x 2;
\@_ = foo();
\@a = foo();
(\@_) = foo();
(\@a) = foo();
\my @c = foo();
(\my @d) = foo();
(\(@_)) = foo();
(\(@a)) = foo();
(\(my @g)) = foo();
\local @_ = \@_;
(\local @_) = \@_;
\state @e = [1..3];
(\(state @f)) = \3;
\our @i = [1..3];
(\(our @h)) = \3;
\%_ = foo();
\%h = foo();
(\%_) = foo();
(\%h) = foo();
\my %c = foo();
(\my %d) = foo();
\local %_ = \%h;
(\local %_) = \%h;
\state %y = {1, 2};
\our %z = {1, 2};
(\our %zz) = {1, 2};
\&a = foo();
(\&a) = foo();
(\&a) = foo();
{
  my sub a;
  \&a = foo();
  (\&a) = foo();
  (\&a) = foo();
}
(\$_, $_) = \(1, 2);
$_ == 3 ? \$_ : $_ = \3;
$_ == 3 ? \$_ : \$x = \3;
($_ == 3 ? \$_ : \$x) = \3;
foreach \my $topic (\$1, \$2) {
    die;
}
foreach \state $topic (\$1, \$2) {
    die;
}
foreach \our $topic (\$1, \$2) {
    die;
}
foreach \$_ (\$1, \$2) {
    die;
}
foreach \my @a ([1, 2], [3, 4]) {
    die;
}
foreach \state @a ([1, 2], [3, 4]) {
    die;
}
foreach \our @a ([1, 2], [3, 4]) {
    die;
}
foreach \@_ ([1, 2], [3, 4]) {
    die;
}
foreach \my %a ({5, 6}, {7, 8}) {
    die;
}
foreach \our %a ({5, 6}, {7, 8}) {
    die;
}
foreach \state %a ({5, 6}, {7, 8}) {
    die;
}
foreach \%_ ({5, 6}, {7, 8}) {
    die;
}
{
    my sub a;
    foreach \&a (sub { 9; } , sub { 10; } ) {
        die;
    }
}
foreach \&a (sub { 9; } , sub { 10; } ) {
    die;
}
####
# CONTEXT no warnings 'experimental::for_list';
my %hash;
foreach my ($key, $value) (%hash) {
    study $_;
}
####
# CONTEXT no warnings 'experimental::for_list';
my @ducks;
foreach my ($tick, $trick, $track) (@ducks) {
    study $_;
}
####
# join $foo, pos
my $foo;
$_ = join $foo, pos
>>>>
my $foo;
$_ = join('???', pos $_);
####
# exists $a[0]
our @a;
exists $a[0];
####
# my @a; exists $a[0]
my @a;
exists $a[0];
####
# delete $a[0]
our @a;
delete $a[0];
####
# my @a; delete $a[0]
my @a;
delete $a[0];
####
# $_[0][$_[1]]
$_[0][$_[1]];
####
# f($a[0]);
my @a;
f($a[0]);
####
#qr/\Q$h{'key'}\E/;
my %h;
qr/\Q$h{'key'}\E/;
####
# my $x = "$h{foo}";
my %h;
my $x = "$h{'foo'}";
####
# weird constant hash key
my %h;
my $x = $h{"\000\t\x{100}"};
####
# multideref and packages
package foo;
my(%bar) = ('a', 'b');
our(@bar) = (1, 2);
$bar{'k'} = $bar[200];
$main::bar{'k'} = $main::bar[200];
$foo::bar{'k'} = $foo::bar[200];
package foo2;
$bar{'k'} = $bar[200];
$main::bar{'k'} = $main::bar[200];
$foo::bar{'k'} = $foo::bar[200];
>>>>
package foo;
my(%bar) = ('a', 'b');
our(@bar) = (1, 2);
$bar{'k'} = $bar[200];
$main::bar{'k'} = $main::bar[200];
$foo::bar{'k'} = $bar[200];
package foo2;
$bar{'k'} = $foo::bar[200];
$main::bar{'k'} = $main::bar[200];
$foo::bar{'k'} = $foo::bar[200];
####
# multideref and local
my %h;
local $h{'foo'}[0] = 1;
####
# multideref and exists
my(%h, $i);
my $e = exists $h{'foo'}[$i];
####
# multideref and delete
my(%h, $i);
my $e = delete $h{'foo'}[$i];
####
# multideref with leading expression
my $r;
my $x = +($r // [])->{'foo'}[0];
####
# multideref with complex middle index
my(%h, $i, $j, $k);
my $x = $h{'foo'}[$i + $j]{$k};
####
# multideref with trailing non-simple index that initially looks simple
# (i.e. the constant "3")
my($r, $i, $j, $k);
my $x = +($r || {})->{'foo'}[$i + $j]{3 + $k};
####
# chdir
chdir 'file';
chdir FH;
chdir;
####
# 5.22 bitops
# CONTEXT use feature "bitwise"; no warnings "experimental::bitwise";
$_ = $_ | $_;
$_ = $_ & $_;
$_ = $_ ^ $_;
$_ = ~$_;
$_ = $_ |. $_;
$_ = $_ &. $_;
$_ = $_ ^. $_;
$_ = ~.$_;
$_ |= $_;
$_ &= $_;
$_ ^= $_;
$_ |.= $_;
$_ &.= $_;
$_ ^.= $_;
####
####
# Should really use 'no warnings "experimental::signatures"',
# but it doesn't yet deparse correctly.
# anon subs used because this test framework doesn't deparse named subs
# in the DATA code snippets.
#
# general signature
no warnings;
use feature 'signatures';
my $x;
sub ($a, $, $b = $glo::bal, $c = $a, $d = 'foo', $e = -37, $f = 0, $g = 1, $h = undef, $i = $a + 1, $j = /foo/, @) {
    $x++;
}
;
$x++;
####
# Signature and prototype
no warnings;
use feature 'signatures';
my $x;
my $f = sub : prototype($$) ($a, $b) {
    $x++;
}
;
$x++;
####
# Signature and prototype and attrs
no warnings;
use feature 'signatures';
my $x;
my $f = sub : prototype($$) lvalue ($a, $b) {
    $x++;
}
;
$x++;
####
# Signature and attrs
no warnings;
use feature 'signatures';
my $x;
my $f = sub : lvalue method ($a, $b) {
    $x++;
}
;
$x++;
####
# named array slurp, null body
no warnings;
use feature 'signatures';
sub (@a) {
    ;
}
;
####
# named hash slurp
no warnings;
use feature 'signatures';
sub ($key, %h) {
    $h{$key};
}
;
####
# anon hash slurp
no warnings;
use feature 'signatures';
sub ($a, %) {
    $a;
}
;
####
# parenthesised default arg
no warnings;
use feature 'signatures';
sub ($a, $b = (/foo/), $c = 1) {
    $a + $b + $c;
}
;
####
# parenthesised default arg with TARGMY
no warnings;
use feature 'signatures';
sub ($a, $b = ($a + 1), $c = 1) {
    $a + $b + $c;
}
;
####
# empty default
no warnings;
use feature 'signatures';
sub ($a, $=) {
    $a;
}
;
####
# defined-or default
no warnings;
use feature 'signatures';
sub ($a //= 'default') {
    $a;
}
;
####
# logical-or default
no warnings;
use feature 'signatures';
sub ($a ||= 'default') {
    $a;
}
;
####
# padrange op within pattern code blocks
/(?{ my($x, $y) = (); })/;
my $a;
/$a(?{ my($x, $y) = (); })/;
my $r1 = qr/(?{ my($x, $y) = (); })/;
my $r2 = qr/$a(?{ my($x, $y) = (); })/;
####
# don't remove pattern whitespace escapes
/a\ b/;
/a\ b/x;
/a\	b/;
/a\	b/x;
####
# my attributes
my $s1 :foo(f1, f2) bar(b1, b2);
my @a1 :foo(f1, f2) bar(b1, b2);
my %h1 :foo(f1, f2) bar(b1, b2);
my($s2, @a2, %h2) :foo(f1, f2) bar(b1, b2);
####
# my class attributes
package Foo::Bar;
my Foo::Bar $s1 :foo(f1, f2) bar(b1, b2);
my Foo::Bar @a1 :foo(f1, f2) bar(b1, b2);
my Foo::Bar %h1 :foo(f1, f2) bar(b1, b2);
my Foo::Bar ($s2, @a2, %h2) :foo(f1, f2) bar(b1, b2);
package main;
my Foo::Bar $s3 :foo(f1, f2) bar(b1, b2);
my Foo::Bar @a3 :foo(f1, f2) bar(b1, b2);
my Foo::Bar %h3 :foo(f1, f2) bar(b1, b2);
my Foo::Bar ($s4, @a4, %h4) :foo(f1, f2) bar(b1, b2);
####
# avoid false positives in my $x :attribute
'attributes'->import('main', \my $x1, 'foo(bar)'), my $y1;
'attributes'->import('Fooo', \my $x2, 'foo(bar)'), my $y2;
####
# hash slices and hash key/value slices
my(@a, %h);
our(@oa, %oh);
@a = @h{'foo', 'bar'};
@a = %h{'foo', 'bar'};
@a = delete @h{'foo', 'bar'};
@a = delete %h{'foo', 'bar'};
@oa = @oh{'foo', 'bar'};
@oa = %oh{'foo', 'bar'};
@oa = delete @oh{'foo', 'bar'};
@oa = delete %oh{'foo', 'bar'};
####
# keys optimised away in void and scalar context
no warnings;
;
our %h1;
my($x, %h2);
%h1;
keys %h1;
$x = %h1;
$x = keys %h1;
%h2;
keys %h2;
$x = %h2;
$x = keys %h2;
####
# eq,const optimised away for (index() == -1)
my($a, $b);
our $c;
$c = index($a, $b) == 2;
$c = rindex($a, $b) == 2;
$c = index($a, $b) == -1;
$c = rindex($a, $b) == -1;
$c = index($a, $b) != -1;
$c = rindex($a, $b) != -1;
$c = (index($a, $b) == -1);
$c = (rindex($a, $b) == -1);
$c = (index($a, $b) != -1);
$c = (rindex($a, $b) != -1);
####
# eq,const,sassign,madmy optimised away for (index() == -1)
my($a, $b);
my $c;
$c = index($a, $b) == 2;
$c = rindex($a, $b) == 2;
$c = index($a, $b) == -1;
$c = rindex($a, $b) == -1;
$c = index($a, $b) != -1;
$c = rindex($a, $b) != -1;
$c = (index($a, $b) == -1);
$c = (rindex($a, $b) == -1);
$c = (index($a, $b) != -1);
$c = (rindex($a, $b) != -1);
####
# plain multiconcat
my($a, $b, $c, $d, @a);
$d = length $a . $b . $c;
$d = length($a) . $b . $c;
print '' . $a;
push @a, ($a . '') * $b;
unshift @a, "$a" * ($b . '');
print $a . 'x' . $b . $c;
print $a . 'x' . $b . $c, $d;
print $b . $c . ($a . $b);
print $b . $c . ($a . $b);
print $b . $c . @a;
print $a . "\x{100}";
####
# double-quoted multiconcat
my($a, $b, $c, $d, @a);
print "${a}x\x{100}$b$c";
print "$a\Q$b\E$c\Ua$a\E\Lb$b\uc$c\E$a${b}c$c";
print "A=$a[length 'b' . $c . 'd'] b=$b";
print "A=@a B=$b";
print "\x{101}$a\x{100}";
$a = qr/\Q
$b $c
\x80
\x{100}
\E$c
/;
####
# sprintf multiconcat
my($a, $b, $c, $d, @a);
print sprintf("%s%s%%%sx%s\x{100}%s", $a, $b, $c, scalar @a, $d);
####
# multiconcat with lexical assign
my($a, $b, $c, $d, $e, @a);
$d = 'foo' . $a;
$d = "foo$a";
$d = $a . '';
$d = 'foo' . $a . 'bar';
$d = $a . $b;
$d = $a . $b . $c;
$d = $a . $b . $c . @a;
$e = ($d = $a . $b . $c);
$d = !$a . $b . $c;
$a = $b . $c . ($a . $b);
$e = f($d = !$a . $b) . $c;
$d = "${a}x\x{100}$b$c";
f($d = !$a . $b . $c);
####
# multiconcat with lexical my
my($a, $b, $c, $d, $e, @a);
my $d1 = 'foo' . $a;
my $d2 = "foo$a";
my $d3 = $a . '';
my $d4 = 'foo' . $a . 'bar';
my $d5 = $a . $b;
my $d6 = $a . $b . $c;
my $e7 = ($d = $a . $b . $c);
my $d8 = !$a . $b . $c;
my $d9 = $b . $c . ($a . $b);
my $da = f($d = !$a . $b) . $c;
my $dc = "${a}x\x{100}$b$c";
f(my $db = !$a . $b . $c);
my $dd = $a . $b . $c . @a;
####
# multiconcat with lexical append
my($a, $b, $c, $d, $e, @a);
$d .= '';
$d .= $a;
$d .= "$a";
$d .= 'foo' . $a;
$d .= "foo$a";
$d .= $a . '';
$d .= 'foo' . $a . 'bar';
$d .= $a . $b;
$d .= $a . $b . $c;
$d .= $a . $b . @a;
$e .= ($d = $a . $b . $c);
$d .= !$a . $b . $c;
$a .= $b . $c . ($a . $b);
$e .= f($d .= !$a . $b) . $c;
f($d .= !$a . $b . $c);
$d .= "${a}x\x{100}$b$c";
####
# multiconcat with expression assign
my($a, $b, $c, @a);
our($d, $e);
$d = 'foo' . $a;
$d = "foo$a";
$d = $a . '';
$d = 'foo' . $a . 'bar';
$d = $a . $b;
$d = $a . $b . $c;
$d = $a . $b . @a;
$e = ($d = $a . $b . $c);
$a["-$b-"] = !$a . $b . $c;
$a[$b]{$c}{$d ? $a : $b . $c} = !$a . $b . $c;
$a = $b . $c . ($a . $b);
$e = f($d = !$a . $b) . $c;
$d = "${a}x\x{100}$b$c";
f($d = !$a . $b . $c);
####
# multiconcat with expression concat
my($a, $b, $c, @a);
our($d, $e);
$d .= 'foo' . $a;
$d .= "foo$a";
$d .= $a . '';
$d .= 'foo' . $a . 'bar';
$d .= $a . $b;
$d .= $a . $b . $c;
$d .= $a . $b . @a;
$e .= ($d .= $a . $b . $c);
$a["-$b-"] .= !$a . $b . $c;
$a[$b]{$c}{$d ? $a : $b . $c} .= !$a . $b . $c;
$a .= $b . $c . ($a . $b);
$e .= f($d .= !$a . $b) . $c;
$d .= "${a}x\x{100}$b$c";
f($d .= !$a . $b . $c);
####
# multiconcat with CORE::sprintf
# CONTEXT sub sprintf {}
my($a, $b);
my $x = CORE::sprintf('%s%s', $a, $b);
####
# multiconcat with backticks
my($a, $b);
our $x;
$x = `$a-$b`;
####
# multiconcat within qr//
my($r, $a, $b);
$r = qr/abc\Q$a-$b\Exyz/;
####
# tr with unprintable characters
my $str;
$str = 'foo';
$str =~ tr/\cA//;
####
# CORE::foo special case in bareword parsing
print $CORE::foo, $CORE::foo::bar;
print @CORE::foo, @CORE::foo::bar;
print %CORE::foo, %CORE::foo::bar;
print $CORE::foo{'a'}, $CORE::foo::bar{'a'};
print &CORE::foo, &CORE::foo::bar;
print &CORE::foo(), &CORE::foo::bar();
print \&CORE::foo, \&CORE::foo::bar;
print *CORE::foo, *CORE::foo::bar;
print stat CORE::foo::, stat CORE::foo::bar;
print CORE::foo:: 1;
print CORE::foo::bar 2;
####
# trailing colons on glob names
no strict 'vars';
$Foo::::baz = 1;
print $foo, $foo::, $foo::::;
print @foo, @foo::, @foo::::;
print %foo, %foo::, %foo::::;
print $foo{'a'}, $foo::{'a'}, $foo::::{'a'};
print &foo, &foo::, &foo::::;
print &foo(), &foo::(), &foo::::();
print \&foo, \&foo::, \&foo::::;
print *foo, *foo::, *foo::::;
print stat Foo, stat Foo::::;
print Foo 1;
print Foo:::: 2;
####
# trailing colons mixed with CORE
no strict 'vars';
print $CORE, $CORE::, $CORE::::;
print @CORE, @CORE::, @CORE::::;
print %CORE, %CORE::, %CORE::::;
print $CORE{'a'}, $CORE::{'a'}, $CORE::::{'a'};
print &CORE, &CORE::, &CORE::::;
print &CORE(), &CORE::(), &CORE::::();
print \&CORE, \&CORE::, \&CORE::::;
print *CORE, *CORE::, *CORE::::;
print stat CORE, stat CORE::::;
print CORE 1;
print CORE:::: 2;
print $CORE::foo, $CORE::foo::, $CORE::foo::::;
print @CORE::foo, @CORE::foo::, @CORE::foo::::;
print %CORE::foo, %CORE::foo::, %CORE::foo::::;
print $CORE::foo{'a'}, $CORE::foo::{'a'}, $CORE::foo::::{'a'};
print &CORE::foo, &CORE::foo::, &CORE::foo::::;
print &CORE::foo(), &CORE::foo::(), &CORE::foo::::();
print \&CORE::foo, \&CORE::foo::, \&CORE::foo::::;
print *CORE::foo, *CORE::foo::, *CORE::foo::::;
print stat CORE::foo::, stat CORE::foo::::;
print CORE::foo:: 1;
print CORE::foo:::: 2;
####
# \&foo
my sub foo {
    1;
}
no strict 'vars';
print \&main::foo;
print \&{foo};
print \&bar;
use strict 'vars';
print \&main::foo;
print \&{foo};
print \&main::bar;
####
# exists(&foo)
my sub foo {
    1;
}
no strict 'vars';
print exists &main::foo;
print exists &{foo};
print exists &bar;
use strict 'vars';
print exists &main::foo;
print exists &{foo};
print exists &main::bar;
# precedence of optimised-away 'keys' (OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS)
my($r1, %h1, $res);
our($r2, %h2);
$res = keys %h1;
$res = keys %h2;
$res = keys %$r1;
$res = keys %$r2;
$res = keys(%h1) / 2 - 1;
$res = keys(%h2) / 2 - 1;
$res = keys(%$r1) / 2 - 1;
$res = keys(%$r2) / 2 - 1;
####
# ditto in presence of sub keys {}
# CONTEXT sub keys {}
no warnings;
my($r1, %h1, $res);
our($r2, %h2);
CORE::keys %h1;
CORE::keys(%h1) / 2;
$res = CORE::keys %h1;
$res = CORE::keys %h2;
$res = CORE::keys %$r1;
$res = CORE::keys %$r2;
$res = CORE::keys(%h1) / 2 - 1;
$res = CORE::keys(%h2) / 2 - 1;
$res = CORE::keys(%$r1) / 2 - 1;
$res = CORE::keys(%$r2) / 2 - 1;
####
# concat: STACKED: ambiguity between .= and optimised nested
my($a, $b);
$b = $a . $a . $a;
(($a .= $a) .= $a) .= $a;
####
# multiconcat: $$ within string
my($a, $x);
$x = "${$}abc";
$x = "\$$a";
####
# single state aggregate assignment
# CONTEXT use feature "state";
state @a = (1, 2, 3);
state %h = ('a', 1, 'b', 2);
####
# state var with attribute
# CONTEXT use feature "state";
state $x :shared;
state $y :shared = 1;
state @a :shared;
state @b :shared = (1, 2);
state %h :shared;
state %i :shared = ('a', 1, 'b', 2);
####
# \our @a shouldn't be a list
my $r = \our @a;
my(@l) = \our((@b));
@l = \our(@c, @d);
####
# postfix $#
our(@b, $s, $l);
$l = (\my @a)->$#*;
(\@b)->$#* = 1;
++(\my @c)->$#*;
$l = $#a;
$#a = 1;
$l = $#b;
$#b = 1;
my $r;
$l = $r->$#*;
$r->$#* = 1;
$l = $#{@$r;};
$#{$r;} = 1;
$l = $s->$#*;
$s->$#* = 1;
$l = $#{@$s;};
$#{$s;} = 1;
####
# TODO doesn't preserve backslash
my @a;
my $s = "$a[0]\[1]";
####
# GH #17301 aux_list() sometimes returned wrong #args
my($r, $h);
$r = $h->{'i'};
$r = $h->{'i'}{'j'};
$r = $h->{'i'}{'j'}{'k'};
$r = $h->{'i'}{'j'}{'k'}{'l'};
$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'};
$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'};
$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'};
$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'};
$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'};
$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'}{'r'};
$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'}{'r'}{'s'};
$r = $h->{'i'}{'j'}{'k'}{'l'}{'m'}{'n'}{'o'}{'p'}{'q'}{'r'}{'s'}{'t'};
####
# chained comparison
my($a, $b, $c, $d, $e, $f, $g);
$a = $b gt $c >= $d;
$a = $b < $c <= $d > $e;
$a = $b == $c != $d;
$a = $b eq $c ne $d == $e;
$a = $b << $c < $d << $e <= $f << $g;
$a = int $b < int $c <= int $d;
$a = ($b < $c) < ($d < $e) <= ($f < $g);
$a = ($b == $c) < ($d == $e) <= ($f == $g);
$a = ($b & $c) < ($d & $e) <= ($f & $g);
$a = $b << $c == $d << $e != $f << $g;
$a = int $b == int $c != int $d;
$a = $b < $c == $d < $e != $f < $g;
$a = ($b == $c) == ($d == $e) != ($f == $g);
$a = ($b & $c) == ($d & $e) != ($f & $g);
$a = $b << ($c < $d <= $e);
$a = int($c < $d <= $e);
$a = $b < ($c < $d <= $e);
$a = $b == $c < $d <= $e;
$a = $b & $c < $d <= $e;
$a = $b << ($c == $d != $e);
$a = int($c == $d != $e);
$a = $b < ($c == $d != $e);
$a = $b == ($c == $d != $e);
$a = $b & $c == $d != $e;
####
# try/catch
# CONTEXT use feature 'try'; no warnings 'experimental::try';
try {
    FIRST();
}
catch($var) {
    SECOND();
}
####
# CONTEXT use feature 'try'; no warnings 'experimental::try';
try {
    FIRST();
}
catch($var) {
    my $x;
    SECOND();
}
####
# CONTEXT use feature 'try'; no warnings 'experimental::try';
try {
    FIRST();
}
catch($var) {
    SECOND();
}
finally {
    THIRD();
}
####
# defer blocks
# CONTEXT use feature "defer"; no warnings 'experimental::defer';
defer {
    $a = 123;
}
####
# builtin:: functions
# CONTEXT no warnings 'experimental::builtin';
my $x;
$x = builtin::is_bool(undef);
$x = builtin::is_weak(undef);
builtin::weaken($x);
builtin::unweaken($x);
$x = builtin::blessed(undef);
$x = builtin::refaddr(undef);
$x = builtin::reftype(undef);
$x = builtin::ceil($x);
$x = builtin::floor($x);
$x = builtin::is_tainted($x);
####
# boolean true preserved
my $x = !0;
####
# boolean false preserved
my $x = !1;
####
# const NV: NV-ness preserved
my(@x) = (-2.0, -1.0, -0.0, 0.0, 1.0, 2.0);
####
# PADSV_STORE optimised my should be handled
() = (my $s = 1);
####
# PADSV_STORE optimised state should be handled
# CONTEXT use feature "state";
() = (state $s = 1);
####
# control transfer in RHS of assignment
my $x;
$x = (return 'ok');
$x //= (return 'ok');
$x = exit 42;
$x //= exit 42;