Login
New Policy: ProhibitAugmentedAssignmentInDeclaration
authorJeffrey Ryan Thalhammer <jeff@imaginative-software.com>
Wed, 21 Dec 2011 22:22:58 +0000 (22:22 +0000)
committerJeffrey Ryan Thalhammer <jeff@imaginative-software.com>
Wed, 21 Dec 2011 22:22:58 +0000 (22:22 +0000)
This was created from a patch provided by Mike O'Regan.
See http://perlcritic.tigris.org/ds/viewMessage.do?dsForumId=4230&dsMessageId=2735595

Changes
lib/Perl/Critic/Policy/Variables/ProhibitAugmentedAssignmentInDeclaration.pm [new file with mode: 0644]
t/Variables/ProhibitAugmentedAssignmentInDeclaration.run [new file with mode: 0644]

diff --git a/Changes b/Changes
index 35688fb..d71f814 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,9 @@
 Next release, whenever it is:
 
+    New Policies:
+    * Variables::ProhibitAugmentedAssignmentInDeclaration reports
+      constructs like 'my $x += 1'. Contributed by Mike O'Regan
+
     Policy Changes:
     * BuiltinFunctions::ProhibitLvalueSubstr: Add explicit 'use version'.
       RT #68498.
diff --git a/lib/Perl/Critic/Policy/Variables/ProhibitAugmentedAssignmentInDeclaration.pm b/lib/Perl/Critic/Policy/Variables/ProhibitAugmentedAssignmentInDeclaration.pm
new file mode 100644 (file)
index 0000000..15bddbe
--- /dev/null
@@ -0,0 +1,121 @@
+package Perl::Critic::Policy::Variables::ProhibitAugmentedAssignmentInDeclaration;
+
+use 5.006001;
+use strict;
+use warnings;
+use List::MoreUtils qw( firstval );
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :data_conversion };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.116';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Augmented assignment operator '%s' used in declaration};
+Readonly::Scalar my $EXPL => q{Use simple assignment when intializing variables};
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return ()                         }
+sub default_severity     { return $SEVERITY_HIGH             }
+sub default_themes       { return qw( core bugs )            }
+sub applies_to           { return 'PPI::Statement::Variable' }
+
+#-----------------------------------------------------------------------------
+
+my %augmented_assignments = hashify( qw( **= += -= .= *= /= %= x= &= |= ^= <<= >>= &&= ||= //= ) );
+
+sub violates {
+    my ( $self, $elem, undef ) = @_;
+
+    # The assignment operator associated with a PPI::Statement::Variable
+    # element is assumed to be the first immediate child of that element.
+    # Other operators in the statement, e.g. the ',' in "my ( $a, $b ) = ();",
+    # as assumed to never be immediate children.
+
+    my $found = List::MoreUtils::firstval { $_->isa('PPI::Token::Operator') } $elem->children();
+    if ( $found ) {
+        my $op = $found->content();
+        if ( !exists $augmented_assignments{ $op } ) {
+            # PPI doesn't parse all augmented assignment operators.  Detect
+            # the unsupported ones by concatenating two immediately adjacent
+            # operators and trying again.
+            my $immediately_adjacent = $found->next_sibling();  # not snext_sibling()
+            if ( $immediately_adjacent && $immediately_adjacent->isa('PPI::Token::Operator') ) {
+                $op .= $immediately_adjacent->content();
+            }
+        }
+
+        if ( exists $augmented_assignments{ $op } ) {
+            return $self->violation( sprintf( $DESC, $op ), $EXPL, $found );
+        }
+    }
+
+    return;
+}
+
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::Variables::ProhibitAugmentedAssignmentInDeclaration - Do not write C< my $foo .= 'bar'; >.
+
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic|Perl::Critic>
+distribution.
+
+
+=head1 DESCRIPTION
+
+Variable declarations that also do initialization with '=' are common.
+Perl also allows you to use operators like '.=', '+=', etc., but it
+it is more clear to not do so.
+
+    my $foo .= 'bar';              # same as my $foo = 'bar';
+    our $foo *= 2;                 # same as our $foo = 0;
+    my ( $foo, $bar ) += ( 1, 2 ); # same as my ( $foo, $bar ) = ( undef, 2 );
+    local $Carp::CarpLevel += 1;   # same as local $Carp::CarpLevel = 1;
+    state $foo += 2;               # adds 2 every time it's encountered
+
+Such constructs are usually the result of botched cut-and-paste, and often are
+bugs. Some produce warnings.
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 AUTHOR
+
+Mike O'Regan
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2011 Mike O'Regan.  All rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.  The full text of this license
+can be found in the LICENSE file included with this module.
+
+=cut
+
+# 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 :
diff --git a/t/Variables/ProhibitAugmentedAssignmentInDeclaration.run b/t/Variables/ProhibitAugmentedAssignmentInDeclaration.run
new file mode 100644 (file)
index 0000000..c3ed67a
--- /dev/null
@@ -0,0 +1,136 @@
+## name Normal assigment ok
+## failures 0
+## cut
+
+my $foo = 0;
+my @bar = ( 'x', 'y', 'z' );
+
+#-----------------------------------------------------------------------------
+
+## name Normal assigment with operators ok
+## failures 0
+## cut
+
+my $foo = 0+0;
+my @bar = ( 'x', 'y', 'z' );
+my $baz = { my $x = 1; $x += 1; $x /= 1; }
+my ( $a, $b ) = ( 0, 0 );
+
+#-----------------------------------------------------------------------------
+
+## name Real-life regression tests
+## failures 0
+## cut
+
+my $exception_class = ($exception_class_for{$class} ||= $class->exception_class);
+my $exception_class = $exception_class_for{$class} ||= $class->exception_class;
+my $feature = ${*$ftp}{net_ftp_feature} ||= do { my @feat; @feat = map { /^\s+(.*\S)/ } $ftp->message if $ftp->_FEAT; \@feat; };
+my $tests = $self->{tests} ||= {};
+my $attr = $_[0]->{A}->{$attrName} ||= new XML::XQL::DirAttr (Parent => $self, Name => $attrName);
+
+
+#-----------------------------------------------------------------------------
+
+## name Scalar augmented assignment
+## failures 64
+## cut
+
+my $foo **=  0;
+my $foo  +=  0;
+my $foo  -=  0;
+my $foo  .=  0;
+my $foo  *=  0;
+my $foo  /=  0;
+my $foo  %=  0;
+my $foo  x=  0;
+my $foo  &=  0;
+my $foo  |=  0;
+my $foo  ^=  0;
+my $foo  <<= 0;
+my $foo  >>= 0;
+my $foo  &&= 0;
+my $foo  ||= 0;
+my $foo  //= 0;
+
+local $foo **=  0;
+local $foo  +=  0;
+local $foo  -=  0;
+local $foo  .=  0;
+local $foo  *=  0;
+local $foo  /=  0;
+local $foo  %=  0;
+local $foo  x=  0;
+local $foo  &=  0;
+local $foo  |=  0;
+local $foo  ^=  0;
+local $foo  <<= 0;
+local $foo  >>= 0;
+local $foo  &&= 0;
+local $foo  ||= 0;
+local $foo  //= 0;
+
+our $foo **=  0;
+our $foo  +=  0;
+our $foo  -=  0;
+our $foo  .=  0;
+our $foo  *=  0;
+our $foo  /=  0;
+our $foo  %=  0;
+our $foo  x=  0;
+our $foo  &=  0;
+our $foo  |=  0;
+our $foo  ^=  0;
+our $foo  <<= 0;
+our $foo  >>= 0;
+our $foo  &&= 0;
+our $foo  ||= 0;
+our $foo  //= 0;
+
+state $foo **=  0;
+state $foo  +=  0;
+state $foo  -=  0;
+state $foo  .=  0;
+state $foo  *=  0;
+state $foo  /=  0;
+state $foo  %=  0;
+state $foo  x=  0;
+state $foo  &=  0;
+state $foo  |=  0;
+state $foo  ^=  0;
+state $foo  <<= 0;
+state $foo  >>= 0;
+state $foo  &&= 0;
+state $foo  ||= 0;
+state $foo  //= 0;
+
+#-----------------------------------------------------------------------------
+
+## name Real-life examples
+## failures 8
+## cut
+
+local $Carp::CarpLevel += $level;
+local $Carp::CarpLevel += ($lvl + 1);
+*$func = sub {  local $Carp::CarpLevel += 2 if grep { $_ eq $func } @EXPORT_OK;
+my $name .= $param->value('Name') ;
+my $curr += ord( lc($char) ) - ord('a') + 1;
+my $port ||= $port_memoized || $ENV{APACHE_TEST_PORT} || $self->{vars}{port} || DEFAULT_PORT;
+my $output .= '<?' . $_[0]->getNodeName;
+my $data .= &stripzerobytes(inet_aton($self->address()));
+
+
+##############################################################################
+#      $URL: http://guest@perlcritic.tigris.org/svn/perlcritic/trunk/distributions/Perl-Critic/t/Variables/ProhibitConditionalDeclarations.run $
+#     $Date: 2009-01-24 19:44:43 -0600 (Sat, 24 Jan 2009) $
+#   $Author: clonezone $
+# $Revision: 3059 $
+##############################################################################
+
+# 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 :