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

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ControlStructures/ProhibitMutatingListFunctions.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::ControlStructures::ProhibitMutatingListFunctions;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13 use Readonly;
  14
  15 use List::MoreUtils qw( none any );
  16
  17 use Perl::Critic::Utils qw{
  18     :booleans :characters :severities :data_conversion :classification :ppi
  19 };
  20
  21 use base 'Perl::Critic::Policy';
  22
  23 our $VERSION = '1.088';
  24
  25 #-----------------------------------------------------------------------------
  26
  27 Readonly::Array my @BUILTIN_LIST_FUNCS => qw( map grep );
  28 Readonly::Array my @CPAN_LIST_FUNCS    => _get_cpan_list_funcs();
  29
  30 #-----------------------------------------------------------------------------
  31
  32 sub _get_cpan_list_funcs {
  33     return  qw( List::Util::first ),
  34         map { 'List::MoreUtils::'.$_ } _get_list_moreutils_funcs();
  35 }
  36
  37 #-----------------------------------------------------------------------------
  38
  39 sub _get_list_moreutils_funcs {
  40     return  qw(any all none notall true false firstidx first_index
  41                lastidx last_index insert_after insert_after_string);
  42 }
  43
  44 #-----------------------------------------------------------------------------
  45
  46 sub _is_topic {
  47     my $elem = shift;
  48     return defined $elem
  49         && $elem->isa('PPI::Token::Magic')
  50             && $elem eq q{$_}; ##no critic (InterpolationOfMetachars)
  51 }
  52
  53
  54 #-----------------------------------------------------------------------------
  55
  56 Readonly::Scalar my $DESC => q{Don't modify $_ in list functions};  ##no critic (InterpolationOfMetachars)
  57 Readonly::Scalar my $EXPL => [ 114 ];
  58
  59 #-----------------------------------------------------------------------------
  60
  61 sub supported_parameters {
  62     return (
  63         {
  64             name            => 'list_funcs',
  65             description     => 'The base set of functions to check.',
  66             default_string  => join ($SPACE, @BUILTIN_LIST_FUNCS, @CPAN_LIST_FUNCS ),
  67             behavior        => 'string list',
  68         },
  69         {
  70             name            => 'add_list_funcs',
  71             description     => 'The set of functions to check, in addition to those given in list_funcs.',
  72             default_string  => $EMPTY,
  73             behavior        => 'string list',
  74         },
  75     );
  76 }
  77
  78 sub default_severity { return $SEVERITY_HIGHEST  }
  79 sub default_themes   { return qw(core bugs pbp)  }
  80 sub applies_to       { return 'PPI::Token::Word' }
  81
  82 #-----------------------------------------------------------------------------
  83
  84 sub initialize_if_enabled {
  85     my ($self, $config) = @_;
  86
  87     $self->{_all_list_funcs} = {
  88         hashify keys %{ $self->{_list_funcs} }, keys %{ $self->{_add_list_funcs} }
  89     };
  90
  91     return $TRUE;
  92 }
  93
  94 #-----------------------------------------------------------------------------
  95
  96 sub violates {
  97     my ($self, $elem, $doc) = @_;
  98
  99     # Is this element a list function?
 100     return if not $self->{_all_list_funcs}->{$elem};
 101     return if not is_function_call($elem);
 102
 103     # Only the block form of list functions can be analyzed.
 104     return if not my $first_arg = first_arg( $elem );
 105     return if not $first_arg->isa('PPI::Structure::Block');
 106     return if not _has_topic_side_effect( $first_arg );
 107
 108     # Must be a violation
 109     return $self->violation( $DESC, $EXPL, $elem );
 110 }
 111
 112 #-----------------------------------------------------------------------------
 113
 114 sub _has_topic_side_effect {
 115     my $node = shift;
 116
 117     # Search through all significant elements in the block,
 118     # testing each element to see if it mutates the topic.
 119     my $tokens = $node->find( 'PPI::Token' ) || [];
 120     for my $elem ( @{ $tokens } ) {
 121         next if not $elem->significant();
 122         return 1 if _is_assignment_to_topic( $elem );
 123         return 1 if _is_topic_mutating_regex( $elem );
 124         return 1 if _is_topic_mutating_func( $elem );
 125         return 1 if _is_topic_mutating_substr( $elem );
 126     }
 127     return;
 128 }
 129
 130 #-----------------------------------------------------------------------------
 131
 132 sub _is_assignment_to_topic {
 133     my $elem = shift;
 134     return if not _is_topic( $elem );
 135
 136     my $sib = $elem->snext_sibling();
 137     if ($sib && $sib->isa('PPI::Token::Operator')) {
 138         return 1 if _is_assignment_operator( $sib );
 139     }
 140
 141     my $psib = $elem->sprevious_sibling();
 142     if ($psib && $psib->isa('PPI::Token::Operator')) {
 143         return 1 if _is_increment_operator( $psib );
 144     }
 145
 146     return;
 147 }
 148
 149 #-----------------------------------------------------------------------------
 150
 151 sub _is_topic_mutating_regex {
 152     my $elem = shift;
 153     return if ! ( $elem->isa('PPI::Token::Regexp::Substitute')
 154                   || $elem->isa('PPI::Token::Regexp::Transliterate') );
 155
 156     # If the previous sibling does not exist, then
 157     # the regex implicitly binds to $_
 158     my $prevsib = $elem->sprevious_sibling;
 159     return 1 if not $prevsib;
 160
 161     # If the previous sibling does exist, then it
 162     # should be a binding operator.
 163     return 1 if not _is_binding_operator( $prevsib );
 164
 165     # Check if the sibling before the biding operator
 166     # is explicitly set to $_
 167     my $bound_to = $prevsib->sprevious_sibling;
 168     return _is_topic( $bound_to );
 169 }
 170
 171 #-----------------------------------------------------------------------------
 172
 173 sub _is_topic_mutating_func {
 174     my $elem = shift;
 175     return if not $elem->isa('PPI::Token::Word');
 176     my @mutator_funcs = qw(chop chomp undef);
 177     return if not any { $elem eq $_ } @mutator_funcs;
 178     return if not is_function_call( $elem );
 179
 180     # If these functions have no argument,
 181     # they default to mutating $_
 182     my $first_arg = first_arg( $elem );
 183     if (not defined $first_arg) {
 184         # undef does not default to $_, unlike the others
 185         return if $elem eq 'undef';
 186         return 1;
 187     }
 188     return _is_topic( $first_arg );
 189 }
 190
 191 #-----------------------------------------------------------------------------
 192
 193 Readonly::Scalar my $MUTATING_SUBSTR_ARG_COUNT => 4;
 194
 195 sub _is_topic_mutating_substr {
 196     my $elem = shift;
 197     return if $elem ne 'substr';
 198     return if not is_function_call( $elem );
 199
 200     # check and see if the first arg is $_
 201     my @args = parse_arg_list( $elem );
 202     return @args >= $MUTATING_SUBSTR_ARG_COUNT && _is_topic( $args[0]->[0] );
 203 }
 204
 205 #-----------------------------------------------------------------------------
 206
 207 {
 208     ##no critic(ArgUnpacking)
 209
 210     my %assignment_ops = hashify qw( = *= /= += -= %= **= x= .= &= |= ^=  &&= ||= ++ -- );
 211     sub _is_assignment_operator { return exists $assignment_ops{$_[0]} }
 212
 213     my %increment_ops = hashify qw( ++ -- );
 214     sub _is_increment_operator { return exists $increment_ops{$_[0]} }
 215
 216     my %binding_ops = hashify qw( =~ !~ );
 217     sub _is_binding_operator { return exists $binding_ops{$_[0]} }
 218 }
 219
 220 1;
 221
 222 #-----------------------------------------------------------------------------
 223
 224 __END__
 225
 226 =pod
 227
 228 =head1 NAME
 229
 230 Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions - Don't modify C<$_> in list functions.
 231
 232 =head1 AFFILIATION
 233
 234 This Policy is part of the core L<Perl::Critic> distribution.
 235
 236
 237 =head1 DESCRIPTION
 238
 239 C<map>, C<grep> and other list operators are intended to transform arrays into
 240 other arrays by applying code to the array elements one by one.  For speed,
 241 the elements are referenced via a C<$_> alias rather than copying them.  As a
 242 consequence, if the code block of the C<map> or C<grep> modify C<$_> in any
 243 way, then it is actually modifying the source array.  This IS technically
 244 allowed, but those side effects can be quite surprising, especially when the
 245 array being passed is C<@_> or perhaps C<values(%ENV)>!  Instead authors
 246 should restrict in-place array modification to C<for(@array) { ... }>
 247 constructs instead, or use C<List::MoreUtils::apply()>.
 248
 249 =head1 CONFIGURATION
 250
 251 By default, this policy applies to the following list functions:
 252
 253   map grep
 254   List::Util qw(first)
 255   List::MoreUtils qw(any all none notall true false firstidx first_index
 256                      lastidx last_index insert_after insert_after_string)
 257
 258 This list can be overridden the F<.perlcriticrc> file like this:
 259
 260  [ControlStructures::ProhibitMutatingListFunctions]
 261  list_funcs = map grep List::Util::first
 262
 263 Or, one can just append to the list like so:
 264
 265  [ControlStructures::ProhibitMutatingListFunctions]
 266  add_list_funcs = Foo::Bar::listmunge
 267
 268 =head1 LIMITATIONS
 269
 270 This policy deliberately does not apply to C<for (@array) { ... }> or
 271 C<List::MoreUtils::apply()>.
 272
 273 Currently, the policy only detects explicit external module usage like this:
 274
 275   my @out = List::MoreUtils::any {s/^foo//} @in;
 276
 277 and not like this:
 278
 279   use List::MoreUtils qw(any);
 280   my @out = any {s/^foo//} @in;
 281
 282 This policy looks only for modifications of C<$_>.  Other naughtiness could
 283 include modifying C<$a> and C<$b> in C<sort> and the like.  That's beyond the
 284 scope of this policy.
 285
 286 =head1 AUTHOR
 287
 288 Chris Dolan <cdolan@cpan.org>
 289
 290 Michael Wolf <MichaelRWolf@att.net>
 291
 292 =head1 COPYRIGHT
 293
 294 Copyright (C) 2006 Chris Dolan.  All rights reserved.
 295
 296 This program is free software; you can redistribute it and/or modify
 297 it under the same terms as Perl itself.
 298
 299 =cut
 300
 301 # Local Variables:
 302 #   mode: cperl
 303 #   cperl-indent-level: 4
 304 #   fill-column: 78
 305 #   indent-tabs-mode: nil
 306 # End:
 307 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
 308