File: ProhibitUnusedCapture.run

package info (click to toggle)
libperl-critic-perl 1.156-1
links: PTS, VCS
area: main
in suites: forky, sid, trixie
size: 3,544 kB
sloc: perl: 24,092; lisp: 341; makefile: 7
file content (703 lines) | stat: -rw-r--r-- 14,084 bytes
## 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 assignment pass
## failures 0
## cut

(substr $str, 0, 1) = m/(\w+)/;

#-----------------------------------------------------------------------------

## name lvalue sub assignment 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 Capture used in an indented here document.
## 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;

#-----------------------------------------------------------------------------

## name @- and @+
## failures 0
## cut

if ( m/(at-minus array)/ ) {
    print @-;
}

if ( m/(at-plus array)/ ) {
    print @+;
}

#-----------------------------------------------------------------------------

## name english @LAST_MATCH_START and @LAST_MATCH_END
## failures 0
## cut

use English

if ( m/(LAST_MATCH_START array)/ ) {
    print @LAST_MATCH_START;
}

if ( m/(LAST_MATCH_END array)/ ) {
    print @LAST_MATCH_END;
}

#-----------------------------------------------------------------------------

## name @{^CAPTURE} added in 5.25.7 (GitHub #778)
## failures 0
## cut

if ( m/(CAPTURE array)/ ) {
    print @{^CAPTURE};
}

if ( m/(quoted CAPTURE array)/ ) {
    print "@{^CAPTURE}\n";
}

if ( m/(CAPTURE array element)/ ) {
    print ${^CAPTURE}[0];
}

if ( m/(quoted CAPTURE array element)/ ) {
    print "${^CAPTURE}[0]\n";
}

#-----------------------------------------------------------------------------

## name %{^CAPTURE_ALL} added in 5.25.7
## failures 0
## cut

if ( m/(?<x>CAPTURE_ALL)/ ) {
    print ${^CAPTURE_ALL}{x};
}

#-----------------------------------------------------------------------------

## name ${^CAPTURE_ALL}[1] has nothing to do with captures
## failures 1
## TODO ${^CAPTURE_ALL}[1] has nothing to do with captures
## cut

if ( m/(CAPTURE_ALL)/ ) {
    print ${^CAPTURE_ALL}[1];
}

## name GitHub #888 - False positive with split
## failures 0
## cut

/(.+)/;
my @a = split /x/, $1;
my @b = split( /x/, $1 );

#-----------------------------------------------------------------------------

## name %- %+ %{^CAPTURE} capture all named captures
## failures 0
## cut

if ( m/(?<%>-)/ ) {
    print %-;
}

if ( m/(?<%>+)/ ) {
    print %+;
}

if ( m/(?<%>^CAPTURE))/ ) {
    print %{^CAPTURE};
}

#-----------------------------------------------------------------------------

## name %LAST_PAREN_MATCH captures all named captures
## failures 0
## cut

use English;

if ( m/(?<x>LAST_PAREN_MATCH)/ ) {
    print %LAST_PAREN_MATCH;
}

#-----------------------------------------------------------------------------

## name %+ doesn't capture unnamed captures
## failures 1
## cut

if ( m/(foo)(?<bar>bar)/ ) {
    print %+;
}

#-----------------------------------------------------------------------------

# 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 :