vcs.maemo.org Git - dh-make-perl/blob - dev/i386/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.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::Subroutines::RequireArgUnpacking;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13 use Readonly;
  14
  15 use File::Spec;
  16 use List::Util qw(first);
  17 use List::MoreUtils qw(uniq any);
  18 use English qw(-no_match_vars);
  19 use Carp;
  20
  21 use Perl::Critic::Utils qw{ :severities words_from_string };
  22 use base 'Perl::Critic::Policy';
  23
  24 our $VERSION = '1.088';
  25
  26 #-----------------------------------------------------------------------------
  27
  28 Readonly::Scalar my $AT => q{@}; ##no critic(Interpolation)
  29 Readonly::Scalar my $AT_ARG => q{@_}; ##no critic(Interpolation)
  30
  31 Readonly::Scalar my $DESC => qq{Always unpack $AT_ARG first};
  32 Readonly::Scalar my $EXPL => [178];
  33
  34 #-----------------------------------------------------------------------------
  35
  36 sub supported_parameters {
  37     return (
  38         {
  39             name            => 'short_subroutine_statements',
  40             description     =>
  41                 'The number of statements to allow without unpacking.',
  42             default_string  => '0',
  43             behavior        => 'integer',
  44             integer_minimum => 0,
  45         },
  46     );
  47 }
  48
  49 sub default_severity     { return $SEVERITY_HIGH             }
  50 sub default_themes       { return qw( core pbp maintenance ) }
  51 sub applies_to           { return 'PPI::Statement::Sub'      }
  52
  53 #-----------------------------------------------------------------------------
  54
  55 sub violates {
  56     my ( $self, $elem, undef ) = @_;
  57
  58     # forward declaration?
  59     return if !$elem->block;
  60
  61     my @statements = $elem->block->schildren;
  62
  63     # empty sub?
  64     return if !@statements;
  65
  66     # Don't apply policy to short subroutines
  67
  68     # Should we instead be doing a find() for PPI::Statement
  69     # instances?  That is, should we count all statements instead of
  70     # just top-level statements?
  71     return if $self->{_short_subroutine_statements} >= @statements;
  72
  73     # look for explicit dereferences of @_, including '$_[0]'
  74     # You may use "... = @_;" in the first paragraph of the sub
  75     # Don't descend into nested or anonymous subs
  76     my $state = 'unpacking'; # still in unpacking paragraph
  77     for my $statement (@statements) {
  78
  79         my @magic = _get_arg_symbols($statement);
  80
  81         my $saw_unpack = 0;
  82       MAGIC:
  83         for my $magic (@magic) {
  84             if ($AT eq $magic->raw_type) {  # this is '@_', not '$_[0]'
  85                 my $prev = $magic->sprevious_sibling;
  86                 my $next = $magic->snext_sibling;
  87
  88                 # allow conditional checks on the size of @_
  89                 next MAGIC if _is_size_check($magic);
  90
  91                 if ('unpacking' eq $state) {
  92                     if (_is_unpack($magic)) {
  93                         $saw_unpack = 1;
  94                         next MAGIC;
  95                     }
  96                 }
  97             }
  98             return $self->violation( $DESC, $EXPL, $elem );
  99         }
 100         if (!$saw_unpack) {
 101             $state = 'post_unpacking';
 102         }
 103     }
 104     return;  # OK
 105 }
 106
 107 sub _is_unpack {
 108     my ($magic) = @_;
 109
 110     my $prev = $magic->sprevious_sibling;
 111     my $next = $magic->snext_sibling;
 112
 113     return 1 if ($prev && $prev->isa('PPI::Token::Operator') && q{=} eq $prev &&
 114                  (!$next || ($next->isa('PPI::Token::Structure') && q{;} eq $next)));
 115     return;
 116 }
 117
 118 sub _is_size_check {
 119     my ($magic) = @_;
 120
 121     my $prev = $magic->sprevious_sibling;
 122     my $next = $magic->snext_sibling;
 123
 124     return 1 if !$next && $prev && $prev->isa('PPI::Token::Operator') &&
 125       (q{==} eq $prev || q{!=} eq $prev);
 126     return 1 if !$prev && $next && $next->isa('PPI::Token::Operator') &&
 127       (q{==} eq $next || q{!=} eq $next);
 128     return;
 129 }
 130
 131 sub _get_arg_symbols {
 132     my ($statement) = @_;
 133
 134     return grep {$AT_ARG eq $_->symbol} @{$statement->find(\&_magic_finder) || []};
 135 }
 136
 137 sub _magic_finder {
 138     # Find all @_ and $_[\d+] not inside of nested subs
 139     my (undef, $elem) = @_;
 140     return 1 if $elem->isa('PPI::Token::Magic'); # match
 141
 142     if ($elem->isa('PPI::Structure::Block')) {
 143         # don't descend into a nested named sub
 144         return if $elem->statement->isa('PPI::Statement::Sub');
 145
 146         my $prev = $elem->sprevious_sibling;
 147         # don't descend into a nested anon sub block
 148         return if $prev && $prev->isa('PPI::Token::Word') && 'sub' eq $prev;
 149     }
 150
 151     return 0; # no match, descend
 152 }
 153
 154
 155 1;
 156
 157 __END__
 158
 159 #-----------------------------------------------------------------------------
 160
 161 =pod
 162
 163 =head1 NAME
 164
 165 Perl::Critic::Policy::Subroutines::RequireArgUnpacking - Always unpack C<@_> first.
 166
 167 =head1 AFFILIATION
 168
 169 This Policy is part of the core L<Perl::Critic> distribution.
 170
 171
 172 =head1 DESCRIPTION
 173
 174 Subroutines that use C<@_> directly instead of unpacking the arguments to
 175 local variables first have two major problems.  First, they are very hard to
 176 read.  If you're going to refer to your variables by number instead of by
 177 name, you may as well be writing assembler code!  Second, C<@_> contains
 178 aliases to the original variables!  If you modify the contents of a C<@_>
 179 entry, then you are modifying the variable outside of your subroutine.  For
 180 example:
 181
 182    sub print_local_var_plus_one {
 183        my ($var) = @_;
 184        print ++$var;
 185    }
 186    sub print_var_plus_one {
 187        print ++$_[0];
 188    }
 189
 190    my $x = 2;
 191    print_local_var_plus_one($x); # prints "3", $x is still 2
 192    print_var_plus_one($x);       # prints "3", $x is now 3 !
 193    print $x;                     # prints "3"
 194
 195 This is spooky action-at-a-distance and is very hard to debug if it's not
 196 intentional and well-documented (like C<chop> or C<chomp>).
 197
 198 =head1 CONFIGURATION
 199
 200 This policy is lenient for subroutines which have C<N> or fewer top-level
 201 statements, where C<N> defaults to ZERO.  You can override this to set it to a
 202 higher number with the C<short_subroutine_statements> setting.  This is very
 203 much not recommended but perhaps you REALLY need high performance.  To do
 204 this, put entries in a F<.perlcriticrc> file like this:
 205
 206   [Subroutines::RequireArgUnpacking]
 207   short_subroutine_statements = 2
 208
 209 =head1 CAVEATS
 210
 211 PPI doesn't currently detect anonymous subroutines, so we don't check those.
 212 This should just work when PPI gains that feature.
 213
 214 We don't check for C<@ARG>, the alias for C<@_> from English.pm.  That's
 215 deprecated anyway.
 216
 217 =head1 CREDITS
 218
 219 Initial development of this policy was supported by a grant from the Perl Foundation.
 220
 221 =head1 AUTHOR
 222
 223 Chris Dolan <cdolan@cpan.org>
 224
 225 =head1 COPYRIGHT
 226
 227 Copyright (c) 2007-2008 Chris Dolan.  Many rights reserved.
 228
 229 This program is free software; you can redistribute it and/or modify
 230 it under the same terms as Perl itself.  The full text of this license
 231 can be found in the LICENSE file included with this module
 232
 233 =cut
 234
 235 # Local Variables:
 236 #   mode: cperl
 237 #   cperl-indent-level: 4
 238 #   fill-column: 78
 239 #   indent-tabs-mode: nil
 240 #   c-indentation-style: bsd
 241 # End:
 242 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :