File Coverage

blib/lib/Perl/Critic/Policy/Variables/RequireNegativeIndices.pm
Criterion Covered Total %
statement 21 103 20.3
branch 0 80 0.0
condition 0 18 0.0
subroutine 10 19 52.6
pod 4 5 80.0
total 35 225 15.5


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