git.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/Variables/RequireNegativeIndices.pm

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Variables/RequireNegativeIndices.pm $
   3 #     $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
   4 #   $Author: clonezone $
   5 # $Revision: 2489 $
   6 ##############################################################################
   7
   8 package Perl::Critic::Policy::Variables::RequireNegativeIndices;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13 use Readonly;
  14
  15 use Perl::Critic::Utils qw{ :severities };
  16 use base 'Perl::Critic::Policy';
  17
  18 our $VERSION = '1.088';
  19
  20 #-----------------------------------------------------------------------------
  21
  22 Readonly::Scalar my $DESC => q{Negative array index should be used};
  23 Readonly::Scalar my $EXPL => [ 88 ];
  24
  25 #-----------------------------------------------------------------------------
  26
  27 sub supported_parameters { return ()                          }
  28 sub default_severity     { return $SEVERITY_HIGH              }
  29 sub default_themes       { return qw( core maintenance pbp )  }
  30 sub applies_to           { return 'PPI::Structure::Subscript' }
  31
  32 #-----------------------------------------------------------------------------
  33
  34 sub violates {
  35     my ( $self, $elem, $doc ) = @_;
  36
  37     return if $elem->braces ne '[]';
  38     my ($name, $isref) = _is_bad_index( $elem );
  39     return if ( !$name );
  40     return if !_is_array_name( $elem, $name, $isref );
  41     return $self->violation( $DESC, $EXPL, $elem );
  42 }
  43
  44 Readonly::Scalar my $MAX_EXPRESSION_COMPLEXETY => 4;
  45
  46 sub _is_bad_index {
  47     # return (varname, 0|1) if this could be a violation
  48     my ( $elem ) = @_;
  49
  50     my @children = $elem->schildren();
  51     return if @children != 1; # too complex
  52     return if !$children[0]->isa( 'PPI::Statement::Expression'); # too complex
  53
  54     # This is the expression elements that compose the array indexing
  55     my @expr = $children[0]->schildren();
  56     return if !@expr || @expr > $MAX_EXPRESSION_COMPLEXETY;
  57     my ($name, $isref, $isindex) = _is_bad_var_in_index(\@expr);
  58     return if !$name;
  59     return $name, $isref if !@expr && $isindex;
  60     return if !_is_minus_number(@expr);
  61     return $name, $isref;
  62 }
  63
  64 sub _is_bad_var_in_index {
  65     # return (varname, isref=0|1, isindex=0|1) if this could be a violation
  66     my ( $expr ) = @_;
  67
  68     if ( $expr->[0]->isa('PPI::Token::ArrayIndex') ) {
  69         # [$#arr]
  70         return _arrayindex($expr);
  71     }
  72     elsif ( $expr->[0]->isa('PPI::Token::Cast') ) {
  73         # [$#{$arr} ...] or [$#$arr ...] or [@{$arr} ...] or [@$arr ...]
  74         return _cast($expr);
  75     }
  76     elsif ($expr->[0]->isa('PPI::Token::Symbol')) {
  77         # [@arr ...]
  78         return _symbol($expr);
  79     }
  80
  81     return;
  82 }
  83
  84 sub _arrayindex {
  85     # return (varname, isref=0|1, isindex=0|1) if this could be a violation
  86     my ( $expr ) = @_;
  87     my $arrindex = shift @{$expr};
  88     if ($arrindex->content =~ m/\A \$[#] (.*) \z /xms) { # What else could it be???
  89        return $1, 0, 1;
  90     }
  91     return;
  92 }
  93
  94 sub _cast {
  95     # return (varname, isref=0|1, isindex=0|1) if this could be a violation
  96     my ( $expr ) = @_;
  97     my $cast = shift @{$expr};
  98     if ( $cast eq q{$#} || $cast eq q{@} ) { ## no critic(RequireInterpolationOfMetachars)
  99         my $isindex = $cast eq q{$#} ? 1 : 0;  ## no critic(RequireInterpolationOfMetachars)
 100         my $arrvar = shift @{$expr};
 101         if ($arrvar->isa('PPI::Structure::Block')) {
 102             # look for [$#{$arr} ...] or [@{$arr} ...]
 103             my @blockchildren = $arrvar->schildren();
 104             return if @blockchildren != 1;
 105             return if !$blockchildren[0]->isa('PPI::Statement');
 106             my @ggg = $blockchildren[0]->schildren;
 107             return if @ggg != 1;
 108             return if !$ggg[0]->isa('PPI::Token::Symbol');
 109             if ($ggg[0] =~ m/\A \$ (.*) \z/xms) {
 110                 return $1, 1, $isindex;
 111             }
 112         }
 113         elsif ( $arrvar->isa('PPI::Token::Symbol') ) {
 114            # look for [$#$arr ...] or [@$arr ...]
 115            if ($arrvar =~ m/\A \$ (.*) \z/xms) {
 116               return $1, 1, $isindex;
 117            }
 118         }
 119     }
 120     return;
 121 }
 122
 123 sub _symbol {
 124     # return (varname, isref=0|1, isindex=0|1) if this could be a violation
 125     my ( $expr ) = @_;
 126     my $arrvar = shift @{$expr};
 127     if ($arrvar =~ m/\A \@ (.*) \z/xms) {
 128        return $1, 0, 0;
 129     }
 130     return;
 131 }
 132
 133 sub _is_minus_number {  # return true if @expr looks like "- n"
 134     my @expr = @_;
 135
 136     return if !@expr;
 137
 138     return if @expr != 2;
 139
 140     my $op = shift @expr;
 141     return if !$op->isa('PPI::Token::Operator');
 142     return if $op ne q{-};
 143
 144     my $number = shift @expr;
 145     return if !$number->isa('PPI::Token::Number');
 146
 147     return 1;
 148 }
 149
 150 sub _is_array_name {  # return true if name and isref matches
 151     my ( $elem, $name, $isref ) = @_;
 152
 153     my $sib = $elem->sprevious_sibling;
 154     return if !$sib;
 155
 156     if ($sib->isa('PPI::Token::Operator') && $sib eq '->') {
 157         return if ( !$isref );
 158         $isref = 0;
 159         $sib = $sib->sprevious_sibling;
 160         return if !$sib;
 161     }
 162
 163     return if !$sib->isa('PPI::Token::Symbol');
 164     return if $sib !~ m/\A \$ \Q$name\E \z/xms;
 165
 166     my $cousin = $sib->sprevious_sibling;
 167     return if $isref ^ _is_dereferencer( $cousin );
 168     return if $isref && _is_dereferencer( $cousin->sprevious_sibling );
 169
 170     return $elem;
 171 }
 172
 173 sub _is_dereferencer { # must return 0 or 1, not undef
 174     my $elem = shift;
 175
 176     return 0 if !$elem;
 177     return 1 if $elem->isa('PPI::Token::Operator') && $elem eq '->';
 178     return 1 if $elem->isa('PPI::Token::Cast');
 179     return 0;
 180 }
 181
 182 1;
 183
 184 #-----------------------------------------------------------------------------
 185
 186 __END__
 187
 188 =pod
 189
 190 =for stopwords performant
 191
 192 =head1 NAME
 193
 194 Perl::Critic::Policy::Variables::RequireNegativeIndices - Negative array index should be used.
 195
 196 =head1 AFFILIATION
 197
 198 This Policy is part of the core L<Perl::Critic> distribution.
 199
 200
 201 =head1 DESCRIPTION
 202
 203 Conway points out that
 204
 205   $arr[$#arr];
 206   $arr[$#arr-1];
 207   $arr[@arr-1];
 208   $arr[@arr-2];
 209
 210 are equivalent to
 211
 212   $arr[-1];
 213   $arr[-2];
 214   $arr[-1];
 215   $arr[-2];
 216
 217 and the latter are more readable, performant and maintainable.  The
 218 latter is because the programmer no longer needs to keep two variable
 219 names matched.
 220
 221 This policy notices all of the simple forms of the above problem, but
 222 does not recognize any of these more complex examples:
 223
 224    $some->[$data_structure]->[$#{$some->[$data_structure]} -1];
 225    my $ref = \@arr;
 226    $ref->[$#arr];
 227
 228
 229 =head1 CONFIGURATION
 230
 231 This Policy is not configurable except for the standard options.
 232
 233
 234 =head1 AUTHOR
 235
 236 Chris Dolan <cdolan@cpan.org>
 237
 238 =head1 COPYRIGHT
 239
 240 Copyright (C) 2006 Chris Dolan.  All rights reserved.
 241
 242 This program is free software; you can redistribute it and/or modify
 243 it under the same terms as Perl itself.
 244
 245 =cut
 246
 247 # Local Variables:
 248 #   mode: cperl
 249 #   cperl-indent-level: 4
 250 #   fill-column: 78
 251 #   indent-tabs-mode: nil
 252 #   c-indentation-style: bsd
 253 # End:
 254 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :