# Copyright 2008, 2009 Kevin Ryde
# This file is part of Perl-Critic-Pulp.
# Perl-Critic-Pulp is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Perl-Critic-Pulp is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Perl-Critic-Pulp. If not, see .
package Perl::Critic::Policy::ValuesAndExpressions::NotWithCompare;
use 5.006;
use strict;
use warnings;
use List::Util qw(min max);
use base 'Perl::Critic::Policy';
use Perl::Critic::Utils qw(:severities
is_perl_builtin
is_perl_builtin_with_no_arguments
precedence_of);
our $VERSION = 22;
sub supported_parameters { return (); }
sub default_severity { return $SEVERITY_MEDIUM; }
sub default_themes { return qw(pulp bugs); }
sub applies_to { return 'PPI::Token::Operator'; }
my %op_postfix = ('++' => 1,
'--' => 1);
my %op_andor = ('&&' => 1,
'||' => 1,
'//' => 1,
'and' => 1,
'or' => 1,
'xor' => 1);
my %post_control = (if => 1,
unless => 1,
until => 1,
for => 1,
foreach => 1,
while => 1);
my %is_bad_precedence = (precedence_of('=~') => 1,
precedence_of('>') => 1,
precedence_of('==') => 1);
my $stop_precedence = max (keys %is_bad_precedence);
sub violates {
my ($self, $bang_elem, $document) = @_;
if ($bang_elem->content ne '!') { return; }
my $constants;
# only report when "!" is at the start of an expression, so "-f ! $x" is
# not applicable (though bizarre), or with "! ! $x" look only from the
# first "!"
if (my $prev = $bang_elem->sprevious_sibling) {
if ($prev->isa('PPI::Token::Operator')) {
my $op = $prev->content;
if (! $op_andor{$op}) { # but do look following "&&" etc
return;
}
}
}
my $state = 'prefix';
my $seen_precedence = 1;
my $elem = $bang_elem;
for (;;) {
$elem or return; # nothing evil up to end of expression
$elem = $elem->snext_sibling
or return; # nothing evil up to end of expression
if ($elem->isa('PPI::Token::Cast')) {
# "\ &foo" is a single form, not a function call
$elem = _next_cast_operand ($elem);
$state = 'postfix';
next;
}
if ($elem->isa('PPI::Token::Symbol')) {
$state = 'postfix';
if ($elem->content =~ /^&/) {
if (my $after = $elem->snext_sibling) {
if ($after->isa('PPI::Structure::List')) {
$elem = $after; # "! &foo() == 1"
next;
}
}
# "! &foo ..." varargs function call, eats to "," or ";"
return;
}
next; # "! $x" etc
}
if ($elem->isa('PPI::Token::Operator')) {
my $op = $elem->content;
if ($state eq 'postfix' && $op_postfix{$op}) {
next; # stay in postfix state after '++' or '--'
}
if ($state eq 'prefix' && $op eq '<') {
# in prefix position assume "<" is "" glob or readline
$elem = _next_gt ($elem);
$state = 'postfix';
next; # can leave $elem undef for something dodgy like "! < 123"
}
my $precedence = _my_precedence_of($op) or return;
if ($precedence > $stop_precedence) {
return; # something below "==" etc, expression to ! is ok
}
if (($op eq '==' || $op eq '!=') && _snext_is_bang($elem)) {
return; # special case "! $x == ! $y" is ok
}
if ($op eq '->') {
if (my $method = $elem->snext_sibling) {
$elem = $method;
$state = 'postfix';
if (my $after = $method->snext_sibling) {
if ($after->isa('PPI::Token::Operator')) {
next; # "! $foo->bar == 1"
}
if ($after->isa('PPI::Structure::List')) {
$elem = $after; # "! $foo->bar() == 1"
next;
}
# bogosity "$foo->bar 123, 456" or the like
return;
}
}
}
if ($seen_precedence <= $precedence && $is_bad_precedence{$precedence}) {
# $op is a compare, so bad
return $self->violation
("Logical \"!\" attempted with a compare \"$op\"",
'', $bang_elem);
}
$seen_precedence = max ($precedence, $seen_precedence);
$state = 'prefix';
next;
}
if ($elem->isa('PPI::Token::Word')) {
my $word = $elem->content;
if ($post_control{$word}) {
return; # postfix control like "$foo = ! $foo if ..." ends expression
}
if (is_perl_builtin_with_no_arguments ($word)) {
# eg "! time ..."
# "time" is a single token, look at operators past it
$state = 'postfix';
next;
}
$constants ||= _constants ($document);
if (exists $constants->{$word}) {
# eg. use constant FOO => 456;
# ! FOO ...
# the FOO is a single token, look at operators past it
$state = 'postfix';
next;
}
my $next = $elem->snext_sibling
or return; # "! FOO" expression ending at a bareword
if ($next->isa('PPI::Structure::List')) {
# "! FOO(...)" function call
$elem = next;
$state = 'postfix';
next;
}
if (is_perl_builtin ($word)) {
return; # builtins all taking args, eating "," or ";"
}
if ($next->isa('PPI::Token::Operator')) {
my $op = $next->content;
if ($op eq '<') {
if (_next_gt ($next)) {
# "! FOO <*.c>" assumed to be glob passed to varargs func, it
# ends at "," or ";" so nothing bad for "!"
return;
}
}
# other "! FOO > 123" assumed to be a constant
$state = 'postfix';
next;
}
# otherwise word is a no parens call, like "foo 123, 456"
# exactly how this parses depends on the prototype, but there's
# going to be a "," or ";" terminating, so our "!" is ok
return;
}
}
return;
}
# in perlcritic 1.088 precedence_of() doesn't recognise the filetest
# operators like "-f"
#
sub _my_precedence_of {
my ($op) = @_;
my $precedence = precedence_of ($op);
if (! defined $precedence) {
if ($op =~ /^-[a-zA-Z]/) {
return precedence_of('>>'); # fakery
}
warn "NotWithCompare: oops, precedence_of() doesn't know operator '$op'";
}
return $precedence;
}
sub _snext_is_bang {
my ($elem) = @_;
my $next = $elem->snext_sibling;
return ($next
&& $next->isa('PPI::Token::Operator')
&& $next eq '!');
}
# return the next ">" operator following $elem, or undef if no such
sub _next_gt {
my ($elem) = @_;
while ($elem = $elem->snext_sibling) {
if ($elem->isa('PPI::Token::Operator') && $elem eq '>') {
last;
}
}
return $elem;
}
# $elem is a PPI::Token::Cast, return its operand elem, meaning the next
# non-Cast (usually a Symbol). Return undef if no non-cast, for something
# dodgy like "\" with nothing following.
sub _next_cast_operand {
my ($elem) = @_;
while ($elem = $elem->snext_sibling) {
if (! $elem->isa('PPI::Token::Cast')) {
last;
}
}
return $elem;
}
# return a hashref which has keys for all the "use constant"s defined in
# $document
sub _constants {
my ($document) = @_;
return ($document->{__PACKAGE__.'.NotWithCompareConstants'} ||= do {
require Perl::Critic::Policy::ValuesAndExpressions::ConstantBeforeLt;
my %constants;
$document->find
(sub {
my ($document, $elem) = @_;
@constants{ Perl::Critic::Policy::ValuesAndExpressions::ConstantBeforeLt::_use_constants($elem) }
= (); # hash slice
return 0; # no-match, and continue
});
\%constants;
});
}
1;
__END__
=head1 NAME
Perl::Critic::Policy::ValuesAndExpressions::NotWithCompare - logical not used with compare
=head1 DESCRIPTION
This policy is part of the L|Perl::Critic::Pulp>
addon. It picks up some cases of logical not C used with a comparison,
like
! $x =~ /^[123]/ # bad
! $x + $y >= $z # bad
In each case precedence means Perl parses this as C<< (!$x) >>, like
(! $x) =~ /^[123]/
(! $x) + $y >= $z
rather than a negated comparison. Usually this is a mistake, so this policy
is under the "bugs" theme (see L).
As a special case, C on both sides of C<< == >> or C<< != >> is allowed,
since it's quite a good way to compare booleans.
!$x == !$y # ok
!$x != !$y # ok
=head1 LIMITATIONS
User functions called without parentheses are assumed to be usual varargs
style. But a prototype may mean that's not the case, letting a bad
C-with-compare expression to go undetected.
! userfunc $x == 123 # indeterminate
# without prototype would be ok: ! (userfunc ($x==123))
# with ($) prototype would be bad: (! userfunc($x)) == 123
Perl builtins with no args, and constant subs created with C