#!./perl
BEGIN {
- unshift @INC, 't';
+ splice @INC, 0, 0, 't', '.';
require Config;
if (($Config::Config{'extensions'} !~ /\bB\b/) ){
print "1..0 # Skip -- Perl configured without B module\n";
use warnings;
use strict;
-my $tests = 32; # not counting those in the __DATA__ section
+my $tests = 52; # not counting those in the __DATA__ section
use B::Deparse;
my $deparse = B::Deparse->new();
new B::Deparse split /,/, $meta{options}
: $deparse;
- my $coderef = eval "$meta{context};\n" . <<'EOC' . "sub {$input\n}";
+ my $code = "$meta{context};\n" . <<'EOC' . "sub {$input\n}";
# Tell B::Deparse about our ambient pragmas
my ($hint_bits, $warning_bits, $hinthash);
BEGIN {
'%^H' => $hinthash,
);
EOC
+ my $coderef = eval $code;
local $::TODO = $meta{todo};
if ($@) {
- is($@, "", "compilation of $desc");
+ is($@, "", "compilation of $desc")
+ or diag "=============================================\n"
+ . "CODE:\n--------\n$code\n--------\n"
+ . "=============================================\n";
}
else {
my $deparsed = $deparse->coderef2text( $coderef );
$regex =~ s/\s+/\\s+/g;
$regex = '^\{\s*' . $regex . '\s*\}$';
- like($deparsed, qr/$regex/, $desc);
+ 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";
}
}
BEGIN { $^I = ".bak"; }
BEGIN { $^W = 1; }
BEGIN { $/ = "\n"; $\ = "\n"; }
-LINE: while (defined($_ = <ARGV>)) {
+LINE: while (defined($_ = readline ARGV)) {
chomp $_;
our(@F) = split(' ', $_, 0);
'???';
$a = `$^X $path "-MO=Deparse" -e "use constant PI => 4" 2>&1`;
$a =~ s/-e syntax OK\n//g;
-is($a, "();\nuse constant ('PI', 4);\n",
+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;
$a = `$^X $path "-MO=Deparse" -e "sub ::::{}sub ::::::{}" 2>&1`;
$a =~ s/-e syntax OK\n//g;
is($a, <<'EOCODG', "sub :::: and sub ::::::");
-();
sub :::: {
}
`$^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;
.
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`;
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;\nCORE::no less;/,
+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;\nCORE::use less;/,
+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.*\nCORE::__DATA__/s,
+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 => 'use Scalar::Util q-weaken-;
+ sub f($);
+ BEGIN { 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 : {
}
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`;
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'} = \\1;\n}\n",
+ '&PL_sv_yes constant (used to croak)';
+
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__
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;
# lexical and package arrays
my @x;
print $main::x[1];
+print \my @a;
####
# lexical and package hashes
my %x;
####
# <>
my $foo;
-$_ .= <ARGV> . <$foo>;
+$_ .= <> . <ARGV> . <$foo>;
+<$foo>;
+<${foo}>;
+<$ foo>;
+>>>>
+my $foo;
+$_ .= readline(ARGV) . readline(ARGV) . readline($foo);
+readline $foo;
+glob $foo;
+glob $foo;
+####
+# 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;
state $z = 1;
}
####
+# foreach with sub call
+foreach $_ (hcaerof()) {
+ ();
+}
+####
# reverse sort
my @x;
print reverse sort(@x);
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 { () };
####
(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
use 5.10.0;
say 'foo';
>>>>
-no feature;
+no feature ':all';
use feature ':5.10';
say 'foo';
####
use 5.10.0;
say 'foo';
>>>>
-no feature;
+no feature ':all';
use feature ':5.10';
say 'foo';
####
use 5.15.0;
__SUB__;
>>>>
-no feature;
+no feature ':all';
use feature ':5.16';
__SUB__;
####
use 5.15.0;
__SUB__;
>>>>
-no feature;
+no feature ':all';
use feature ':5.16';
__SUB__;
####
# /$#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 =~ //;
print /a/d, s/b/c/d;
}
{
- no feature;
+ 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;
+####
+# all the flags (tr///)
+tr/X/Y/c;
+tr/X//d;
+tr/X//s;
+tr/X//r;
+####
# [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns)
s/foo/\(3);/eg;
####
s/$a(??{ die $b; })//;
s/@a(??{ die $b; })//;
####
+# /(?x)<newline><tab>/
+/(?x)
+ /;
+####
# y///r
tr/a/b/r + $a =~ tr/p/q/r;
####
####
# [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 $~;
CORE::evalbytes '';
() = CORE::__SUB__;
>>>>
-no feature;
+no feature ':all';
use feature ':default';
CORE::say $_;
CORE::state $x;
>>>>
use feature 'current_sub', 'evalbytes';
print $_;
-no feature;
+no feature ':all';
use feature ':default';
print $_;
-no feature;
+no feature ':all';
use feature ':5.12';
print $_;
no feature 'unicode_strings';
@x = ($#{`}, $#{~}, $#{!}, $#{@}, $#{$}, $#{%}, $#{^}, $#{&}, $#{*});
@x = ($#{(}, $#{)}, $#{[}, $#{{}, $#{]}, $#{}}, $#{'}, $#{"}, $#{,});
@x = ($#{<}, $#{.}, $#{>}, $#{/}, $#{?}, $#{=}, $#+, $#{\}, $#{|}, $#-);
-@x = ($#{;}, $#{:});
+@x = ($#{;}, $#{:}, $#{1}), $#_;
####
# ${#} interpolated
# It's a known TODO that warnings are deparsed as bits, not textually.
/${|}/;
/${)}/;
/${(}${|}${)}/;
+/@{+}@{-}/;
####
# ()[...]
my(@a) = ()[()];
() = (-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);
####
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
# lexical subroutine
-use feature 'lexical_subs';
+# CONTEXT use feature 'lexical_subs';
no warnings "experimental::lexical_subs";
my sub f {}
print f();
>>>>
-use feature 'lexical_subs';
-BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUUU\005"}
+BEGIN {${^WARNING_BITS} = "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
my sub f {
- BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUU\005"}
}
-BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUU\005"}
print f();
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
# lexical "state" subroutine
-use feature 'state', 'lexical_subs';
+# CONTEXT use feature 'state', 'lexical_subs';
no warnings 'experimental::lexical_subs';
state sub f {}
print f();
>>>>
-use feature 'lexical_subs';
-BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUUU\005"}
-CORE::state sub f {
- BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUU\005"}
- use feature 'state';
+BEGIN {${^WARNING_BITS} = "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"}
+state sub f {
}
-BEGIN {${^WARNING_BITS} = "TUUUUUUUUUUUUTUU\005"}
-use feature 'state';
print f();
####
# SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version"
{
foo();
my sub b;
- b();
+ b ;
main::b();
&main::b;
&main::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 { }
+}
+####
+# TODO only partially fixed
+# 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 #12335]
+# $; [perl #123357]
$_ = $;;
do {
$;
};
####
-# [perl #121050] Prototypes with whitespace
-sub _121050(\$ \$) { }
-_121050($a,$b);
-sub _121050empty( ) {}
-() = _121050empty() + 1;
+# Ampersand calls and scalar context
+# OPTIONS -P
+package prototest;
+sub foo($$);
+foo(bar(),baz());
>>>>
-_121050 $a, $b;
-() = _121050empty + 1;
+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);
+>>>>
+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));
####
# ensure aelemfast works in the range -128..127 and that there's no
# funky edge cases
>>>>
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;
+sub ($a, $b) : prototype($$) {
+ $x++;
+}
+;
+$x++;
+####
+# Signature and prototype and attrs
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $b) : prototype($$) lvalue {
+ $x++;
+}
+;
+$x++;
+####
+# Signature and attrs
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $b) : lvalue method {
+ $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;
+}
+;
+####
+# 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);
https://perl5.git.perl.org / perl5.git / blobdiff