## name non-captures
## failures 0
## cut
m/foo/;
m/(?:foo)/;
if (m/foo/) {
print "bar";
}
#-----------------------------------------------------------------------------
## name assignment captures
## failures 0
## cut
my ($foo) = m/(foo)/;
my ($foo) = m/(foo|bar)/;
my ($foo) = m/(foo)(?:bar)/;
my @foo = m/(foo)/;
my @foo = m/(foo)/g;
my %foo = m/(foo)(bar)/g;
my ($foo, $bar) = m/(foo)(bar)/;
my @foo = m/(foo)(bar)/;
my ($foo, @bar) = m/(foo)(bar)/;
my ($foo, @bar) = m/(foo)(bar)(baz)/;
#-----------------------------------------------------------------------------
## name undef array captures
## failures 0
## cut
() = m/(foo)/;
(undef) = m/(foo)/;
my ($foo) =()= m/(foo)/g;
#-----------------------------------------------------------------------------
## name complex array assignment captures
## failures 0
## cut
@$foo = m/(foo)(bar)/;
@{$foo} = m/(foo)(bar)/;
%$foo = m/(foo)(bar)/;
%{$foo} = m/(foo)(bar)/;
($foo,@$foo) = m/(foo)(bar)/;
($foo,@{$foo}) = m/(foo)(bar)/;
#-----------------------------------------------------------------------------
## name conditional captures
## failures 0
## cut
if (m/(foo)/) {
my $foo = $1;
print $foo;
}
if (m/(foo)(bar)/) {
my $foo = $1;
my $bar = $2;
print $foo, $bar;
}
if (m/(foo)(bar)/) {
my ($foo, $bar) = ($1, $2);
print $foo, $bar;
}
if (m/(foo)(bar)/) {
my (@foo) = ($1, $2);
print @foo;
}
if (m/(foo)/) {
# bug, but not a violation of THIS policy
my (@foo) = ($1, $2);
print @foo;
}
#-----------------------------------------------------------------------------
## name RT #38942
## failures 0
## cut
while ( pos() < length ) {
m{\G(a)(b)(c)}gcxs or die;
my ($a, $b, $c) = ($1, $2, $3);
}
#-----------------------------------------------------------------------------
## name boolean and ternary captures
## failures 0
## cut
m/(foo)/ && print $1;
m/(foo)/ ? print $1 : die;
m/(foo)/ && ($1 == 'foo') ? print 1 : die;
#-----------------------------------------------------------------------------
## name loop captures
## failures 0
## cut
for (m/(foo)/) {
my $foo = $1;
print $foo;
}
#-----------------------------------------------------------------------------
## name slurpy array loop captures
## failures 0
## cut
map {print} m/(foo)/;
foo(m/(foo)/);
foo('bar', m/(foo)/);
foo(m/(foo)/, 'bar');
foo m/(foo)/;
foo 'bar', m/(foo)/;
foo m/(foo)/, 'bar';
## name slurpy with assignment
## failures 0
## cut
my ($foo) = grep {$b++ == 2} m/(foo)/g;
my ($foo) = grep {$b++ == 2} $str =~ m/(foo)/g;
#-----------------------------------------------------------------------------
## name slurpy with array assignment
## failures 0
## cut
my @foo = grep {$b++ > 2} m/(foo)/g;
my @foo = grep {$b++ > 2} $str =~ m/(foo)/g;
#-----------------------------------------------------------------------------
## name assignment captures on string
## failures 0
## cut
my ($foo) = $str =~ m/(foo)/;
my ($foo) = $str =~ m/(foo|bar)/;
my ($foo) = $str =~ m/(foo)(?:bar)/;
my @foo = $str =~ m/(foo)/;
my @foo = $str =~ m/(foo)/g;
my ($foo, $bar) = $str =~ m/(foo)(bar)/;
my @foo = $str =~ m/(foo)(bar)/;
my ($foo, @bar) = $str =~ m/(foo)(bar)/;
my (@bar) = $str =~ m/(foo)(bar)/;
my ($foo, @bar) = $str =~ m/(foo)(bar)(baz)/;
#-----------------------------------------------------------------------------
## name slurpy captures on string
## failures 0
## cut
map {print} $str =~ m/(foo)/g;
#-----------------------------------------------------------------------------
## name self captures
## failures 0
## cut
m/(foo)\1/;
s/(foo)/$1/;
s/(foo)/\1/;
s<\A t[\\/] (\w+) [\\/] (\w+) [.]run \z><$1\::$2>xms
#-----------------------------------------------------------------------------
## name basic failures
## failures 5
## cut
m/(foo)/;
my ($foo) = m/(foo)/g;
if (m/(foo)/) {
print "bar";
}
if (m/(foo)(bar)/) {
my $foo = $1;
print $foo;
}
for (m/(foo)/) {
print "bar";
}
#-----------------------------------------------------------------------------
## name negated regexp failures
## failures 1
## cut
my ($foo) = $str !~ m/(foo)/;
#-----------------------------------------------------------------------------
## name statement failures
## failures 1
## cut
m/(foo)/ && m/(bar)/ && print $1;
#-----------------------------------------------------------------------------
## name sub failures
## failures 1
## cut
sub foo {
m/(foo)/;
return;
}
print $1;
#-----------------------------------------------------------------------------
## name anon sub failures
## failures 1
## TODO PPI v1.118 doesn't recognize anonymous subroutines
## cut
my $sub = sub foo {
m/(foo)/;
return;
};
print $1;
#-----------------------------------------------------------------------------
## name ref constructors
## failures 0
## cut
$f = { m/(\w+)=(\w+)/g };
$f = [ m/(\w+)/g ];
#-----------------------------------------------------------------------------
## name sub returns
## failures 0
## cut
sub foo {
m/(foo)/;
}
sub foo {
return m/(foo)/;
}
map { m/(foo)/ } (1, 2, 3);
#-----------------------------------------------------------------------------
## name failing regexp with syntax error
## failures 0
## cut
m/(foo)(/;
#-----------------------------------------------------------------------------
## name lvalue sub assigment pass
## failures 0
## cut
(substr $str, 0, 1) = m/(\w+)/;
#-----------------------------------------------------------------------------
## name lvalue sub assigment failure
## failures 1
## TODO lvalue subs are too complex to support
## cut
(substr $str, 0, 1) = m/(\w+)(\d+)/;
#-----------------------------------------------------------------------------
## name code coverage
## failures 1
## cut
m/(foo)/;
print $0;
print @ARGV;
print $_;
#-----------------------------------------------------------------------------
## name while loop with /g
## failures 0
## cut
while (m/(\d+)/g) {
print $1, "\n";
}
#-----------------------------------------------------------------------------
## name conditional named captures
## failures 0
## cut
if ( m/(?<foo>bar)/ ) {
print $+{foo}, "\n";
}
while ( m/(?'foo'\d+)/g ) {
print $-{foo}[0], "\n";
}
m/(?P<foo>\w+)|(?<foo>\W+)/ and print $+{foo}, "\n";
#-----------------------------------------------------------------------------
## name named capture in array context is unused
## failures 2
## cut
my @foo = m/(?<foo>\w+)/;
sub foo {
return m/(?<foo>\W+)/;
}
#-----------------------------------------------------------------------------
## name named capture in array context with siblings is OK
## failures 0
## cut
my @foo = m/(?<foo>\w+)/;
print $+{foo}, "\n";
#-----------------------------------------------------------------------------
## name named capture not used in replacement
## failures 1
## cut
s/(?<foo>\w+)/foo$1/g;
#-----------------------------------------------------------------------------
## name named capture used in replacement
## failures 0
## cut
s/(?<foo>\w+)/foo$+{foo}/g;
#-----------------------------------------------------------------------------
## name subscripted capture
## failures 0
## cut
s/(foo)/$+[ 1 ]/;
s/(foo)/$-[ 1 ]/;
s/(foo)/$+[ -1 ]/;
s/(foo)/$-[ -1 ]/;
m/(\w+)/ and print substr( $_, $-[ 1 ], $+[ 1 ] - $-[ 1 ] );
m/(\w+)/ and print substr( $_, $-[ -1 ], $+[ -1 ] - $-[ -1 ] );
#-----------------------------------------------------------------------------
## name named capture English name in replacement RT #60002
## failures 1
## cut
s/(?<foo>\w+)/foo$LAST_PAREN_MATCH{foo}/g;
#-----------------------------------------------------------------------------
## name named capture English name in code RT #60002
## failures 1
## cut
m/(?P<foo>\w+)|(?<foo>\W+)/ and print $LAST_PAREN_MATCH{foo}, "\n";
#-----------------------------------------------------------------------------
## name named capture English name in replacement RT #60002
## failures 0
## cut
use English;
s/(?<foo>\w+)/foo$LAST_PAREN_MATCH{foo}/g;
#-----------------------------------------------------------------------------
## name named capture English name in code RT #60002
## failures 0
## cut
use English;
m/(?P<foo>\w+)|(?<foo>\W+)/ and print $LAST_PAREN_MATCH{foo}, "\n";
#-----------------------------------------------------------------------------
## name English subscripted capture without use English
## failures 6
## cut
s/(foo)/$LAST_MATCH_END[ 1 ]/;
s/(foo)/$LAST_MATCH_START[ 1 ]/;
s/(foo)/$LAST_MATCH_END[ -1 ]/;
s/(foo)/$LAST_MATCH_START[ -1 ]/;
m/(\w+)/ and print substr(
$_, $LAST_MATCH_START[ 1 ], $LAST_MATCH_END[ 1 ] - $LAST_MATCH_START[ 1 ] );
m/(\w+)/ and print substr(
$_, $LAST_MATCH_START[ -1 ],
$LAST_MATCH_END[ -1 ] - $LAST_MATCH_START[ -1 ] );
#-----------------------------------------------------------------------------
## name English subscripted capture with use English
## failures 0
## cut
use English;
s/(foo)/$LAST_MATCH_END[ 1 ]/;
s/(foo)/$LAST_MATCH_START[ 1 ]/;
s/(foo)/$LAST_MATCH_END[ -1 ]/;
s/(foo)/$LAST_MATCH_START[ -1 ]/;
m/(\w+)/ and print substr(
$_, $LAST_MATCH_START[ 1 ], $LAST_MATCH_END[ 1 ] - $LAST_MATCH_START[ 1 ] );
m/(\w+)/ and print substr(
$_, $LAST_MATCH_START[ -1 ],
$LAST_MATCH_END[ -1 ] - $LAST_MATCH_START[ -1 ] );
#-----------------------------------------------------------------------------
## name Capture used in substitution portion of s/.../.../e
## failures 0
## cut
s/(\w+)/$replace{$1} || "<$1>"/ge;
#-----------------------------------------------------------------------------
## name Capture used in double-quotish string. RT #38942 redux
## failures 0
## cut
m/(\w+)(\W+)/;
print "$+[2] $1";
m/(?<foo>(\w+)/;
print "$+{foo}";
m/(\d+)/;
print "${1}234";
#-----------------------------------------------------------------------------
## name Capture used in a here document. RT #38942 redux
## failures 0
## cut
m/(\w+)(\W+)/;
print <<EOD
$+[2] $1
EOD
#-----------------------------------------------------------------------------
## name Alternation. RT #38942 redux
## failures 0
## cut
if ( /(a)/ || /(b)/ ) {
say $1;
}
# Yes, this is incorrect code, but that's ProhibitCaptureWithoutTest's
# problem.
if ( /(a)/ // /(b)/ ) {
say $1;
}
# Contrived, but worse things happen at sea.
if ( ( /(a)/ || undef ) // /(b)/ ) {
say $1;
}
if ( /(a)/ or /(b)/ ) {
say $1;
}
#-----------------------------------------------------------------------------
## name Alternation with conjunction. RT #38942 redux
## failures 4
## cut
# 1 failure here: the /(b)/
if ( /(a)/ || /(b)/ && /(c)/ ) {
say $1;
}
# 1 failure here: the /(b)/
if ( /(a)/ or /(b)/ and /(c)/ ) {
say $1;
}
# 2 failures here: the /(a)/ and the /(b)/
if ( /(a)/ || /(b)/ and /(c)/ ) {
say $1;
}
#-----------------------------------------------------------------------------
## name RT #67116 - Incorrect check of here document.
## failures 1
## cut
$x !~ /()/;
<<X;
.
.
.
X
#-----------------------------------------------------------------------------
## name RT #69867 - Incorrect check of if() statement if regexp negated
## failures 0
## cut
if ( $ip !~ /^(.*?)::(.*)\z/sx ) {
@fields = split /:/x, $ip;
} else {
my ( $before, $after ) = ( $1, $2 );
}
#-----------------------------------------------------------------------------
## name RT #72086 - False positive with /e and parens
## failures 0
## cut
s/(.)/($1)/e;
s/(.)/ { $1 } /e;
#-----------------------------------------------------------------------------
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 78
# indent-tabs-mode: nil
# c-indentation-style: bsd
# End:
# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :