Login
RT #74429: 'Negative array index should be used' a little misleading
[gknop/Perl-Critic.git] / lib / Perl / Critic / Policy / Variables / RequireNegativeIndices.pm
CommitLineData
6036a254 1##############################################################################
1bd11ec1
CD
2# $URL$
3# $Date$
4# $Author$
5# $Revision$
6036a254 6##############################################################################
1bd11ec1
CD
7
8package Perl::Critic::Policy::Variables::RequireNegativeIndices;
9
df6dee2b 10use 5.006001;
1bd11ec1
CD
11use strict;
12use warnings;
c680a9c9
ES
13use Readonly;
14
bbf4108c 15use Perl::Critic::Utils qw{ :severities };
1bd11ec1
CD
16use base 'Perl::Critic::Policy';
17
73c61a84 18our $VERSION = '1.117';
1bd11ec1 19
6036a254 20#-----------------------------------------------------------------------------
1bd11ec1 21
c680a9c9
ES
22Readonly::Scalar my $DESC => q{Negative array index should be used};
23Readonly::Scalar my $EXPL => [ 88 ];
1bd11ec1 24
6036a254 25#-----------------------------------------------------------------------------
1bd11ec1 26
c680a9c9
ES
27sub supported_parameters { return () }
28sub default_severity { return $SEVERITY_HIGH }
29sub default_themes { return qw( core maintenance pbp ) }
30sub applies_to { return 'PPI::Structure::Subscript' }
1bd11ec1 31
6036a254 32#-----------------------------------------------------------------------------
1bd11ec1
CD
33
34sub 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 );
c680a9c9 41 return $self->violation( $DESC, $EXPL, $elem );
1bd11ec1
CD
42}
43
05b5f925
ES
44Readonly::Scalar my $MAX_EXPRESSION_COMPLEXETY => 4;
45
1bd11ec1
CD
46sub _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
8e2aefdb 53
1bd11ec1
CD
54 # This is the expression elements that compose the array indexing
55 my @expr = $children[0]->schildren();
05b5f925 56 return if !@expr || @expr > $MAX_EXPRESSION_COMPLEXETY;
1bd11ec1
CD
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
64sub _is_bad_var_in_index {
65 # return (varname, isref=0|1, isindex=0|1) if this could be a violation
66 my ( $expr ) = @_;
67
1bd11ec1 68 if ( $expr->[0]->isa('PPI::Token::ArrayIndex') ) {
876c81c6
CD
69 # [$#arr]
70 return _arrayindex($expr);
1bd11ec1
CD
71 }
72 elsif ( $expr->[0]->isa('PPI::Token::Cast') ) {
876c81c6
CD
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
84sub _arrayindex {
85 # return (varname, isref=0|1, isindex=0|1) if this could be a violation
86 my ( $expr ) = @_;
87 my $arrindex = shift @{$expr};
e25c095f 88 if ($arrindex->content =~ m/\A \$[#] (.*) \z /xms) { # What else could it be???
876c81c6 89 return $1, 0, 1;
1bd11ec1 90 }
876c81c6
CD
91 return;
92}
93
94sub _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)
1bd11ec1 100 my $arrvar = shift @{$expr};
876c81c6
CD
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 }
1bd11ec1 119 }
876c81c6
CD
120 return;
121}
1bd11ec1 122
876c81c6
CD
123sub _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;
1bd11ec1
CD
131}
132
c79c8b5b 133sub _is_minus_number { # return true if @expr looks like "- n"
1bd11ec1
CD
134 my @expr = @_;
135
136 return if !@expr;
137
1bd11ec1
CD
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{-};
8e2aefdb 143
1bd11ec1
CD
144 my $number = shift @expr;
145 return if !$number->isa('PPI::Token::Number');
146
147 return 1;
148}
149
150sub _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
173sub _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
1821;
183
6036a254 184#-----------------------------------------------------------------------------
1bd11ec1
CD
185
186__END__
187
188=pod
189
a73f4a71
JRT
190=for stopwords performant
191
1bd11ec1
CD
192=head1 NAME
193
b16bd0f6 194Perl::Critic::Policy::Variables::RequireNegativeIndices - Negative array index should be used.
1bd11ec1 195
11f53956 196
af93c316
ES
197=head1 AFFILIATION
198
11f53956
ES
199This Policy is part of the core L<Perl::Critic|Perl::Critic>
200distribution.
af93c316
ES
201
202
1bd11ec1
CD
203=head1 DESCRIPTION
204
8913f8b8
TW
205Perl treats a negative array subscript as an offset from the end. Given
206this, the preferred way to get the last element is C<$x[-1]>, not
207C<$x[$#x]> or C<$x[@x-1]>, and the preferred way to get the next-to-last
208is C<$x[-2]>, not C<$x[$#x-1> or C<$x[@x-2]>.
1bd11ec1 209
8913f8b8
TW
210The biggest argument against the non-preferred forms is that B<their
211semantics change> when the computed index becomes negative. If C<@x>
212contains at least two elements, C<$x[$#x-1]> and C<$x[@x-2]> are
213equivalent to C<$x[-2]>. But if it contains a single element,
214C<$x[$#x-1]> and C<$x[@x-2]> are both equivalent to C<$x[-1]>. Simply
215put, the preferred form is more likely to do what you actually want.
1bd11ec1 216
8913f8b8
TW
217As Conway points out, the preferred forms also perform better, are more
218readable, and are easier to maintain.
1bd11ec1
CD
219
220This policy notices all of the simple forms of the above problem, but
221does not recognize any of these more complex examples:
222
11f53956 223 $some->[$data_structure]->[$#{$some->[$data_structure]} -1];
8913f8b8 224 my $ref = \@arr; $ref->[$#arr];
1bd11ec1 225
0cb729f0
ES
226
227=head1 CONFIGURATION
228
49860482 229This Policy is not configurable except for the standard options.
0cb729f0
ES
230
231
1bd11ec1
CD
232=head1 AUTHOR
233
234Chris Dolan <cdolan@cpan.org>
235
11f53956 236
1bd11ec1
CD
237=head1 COPYRIGHT
238
53b8903f 239Copyright (c) 2006-2011 Chris Dolan.
1bd11ec1
CD
240
241This program is free software; you can redistribute it and/or modify
242it under the same terms as Perl itself.
243
244=cut
737d3b65
CD
245
246# Local Variables:
247# mode: cperl
248# cperl-indent-level: 4
249# fill-column: 78
250# indent-tabs-mode: nil
251# c-indentation-style: bsd
252# End:
96fed375 253# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :