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

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.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::ProhibitManyArgs;
   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{ :booleans :severities split_nodes_on_comma };
  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 => q{Too many arguments};
  32 Readonly::Scalar my $EXPL => [182];
  33
  34 #-----------------------------------------------------------------------------
  35
  36 sub supported_parameters {
  37     return (
  38         {
  39             name            => 'max_arguments',
  40             description     =>
  41                 'The maximum number of arguments to allow a subroutine to have.',
  42             default_string  => '5',
  43             behavior        => 'integer',
  44             integer_minimum => 1,
  45         },
  46     );
  47 }
  48
  49 sub default_severity     { return $SEVERITY_MEDIUM           }
  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 $num_args;
  62     if ($elem->prototype) {
  63        # subtract two for the "()" on the prototype
  64        $num_args = -2 + length $elem->prototype;  ## no critic (ProhibitMagicNumbers)
  65     } else {
  66        $num_args = _count_args($elem->block->schildren);
  67     }
  68
  69     if ($self->{_max_arguments} < $num_args) {
  70        return $self->violation( $DESC, $EXPL, $elem );
  71     }
  72     return;  # OK
  73 }
  74
  75 sub _count_args {
  76     my @statements = @_;
  77
  78     # look for these patterns:
  79     #    " ... = @_;"    => then examine previous variable list
  80     #    " ... = shift;" => counts as one arg, then look for more
  81
  82     return 0 if !@statements;  # no statements
  83
  84     my $statement = shift @statements;
  85     my @elements = $statement->schildren();
  86     my $operand = pop @elements;
  87     while ($operand && $operand->isa('PPI::Token::Structure') && q{;} eq $operand) {
  88        $operand = pop @elements;
  89     }
  90     return 0 if !$operand;
  91
  92     #print "pulled off last, remaining: '@elements'\n";
  93     my $operator = pop @elements;
  94     return 0 if !$operator;
  95     return 0 if !$operator->isa('PPI::Token::Operator');
  96     return 0 if q{=} ne $operator;
  97
  98     if ($operand->isa('PPI::Token::Magic') && $AT_ARG eq $operand) {
  99        return _count_list_elements(@elements);
 100     } elsif ($operand->isa('PPI::Token::Word') && 'shift' eq $operand) {
 101        return 1 + _count_args(@statements);
 102     }
 103
 104     return 0;
 105 }
 106
 107 sub _count_list_elements {
 108    my @elements = @_;
 109
 110    my $list = pop @elements;
 111    return 0 if !$list;
 112    return 0 if !$list->isa('PPI::Structure::List');
 113    my @inner = $list->schildren;
 114    if (1 == @inner && $inner[0]->isa('PPI::Statement::Expression')) {
 115       @inner = $inner[0]->schildren;
 116    }
 117    return scalar split_nodes_on_comma(@inner);
 118 }
 119
 120 1;
 121
 122 __END__
 123
 124 #-----------------------------------------------------------------------------
 125
 126 =pod
 127
 128 =for stopwords refactored
 129
 130 =head1 NAME
 131
 132 Perl::Critic::Policy::Subroutines::ProhibitManyArgs - Too many arguments.
 133
 134 =head1 AFFILIATION
 135
 136 This Policy is part of the core L<Perl::Critic> distribution.
 137
 138
 139 =head1 DESCRIPTION
 140
 141 Subroutines that expect large numbers of arguments are hard to use
 142 because programmers routinely have to look at documentation to
 143 remember the order of those arguments.  Many arguments is often a sign
 144 that a subroutine should be refactored or that an object should be
 145 passed to the routine.
 146
 147 =head1 CONFIGURATION
 148
 149 By default, this policy allows up to 5 arguments without warning.  To
 150 change this threshold, put entries in a F<.perlcriticrc> file like
 151 this:
 152
 153   [Subroutines::ProhibitManyArgs]
 154   max_arguments = 6
 155
 156 =head1 CAVEATS
 157
 158 PPI doesn't currently detect anonymous subroutines, so we don't check those.
 159 This should just work when PPI gains that feature.
 160
 161 We don't check for C<@ARG>, the alias for C<@_> from English.pm.  That's
 162 deprecated anyway.
 163
 164 =head1 CREDITS
 165
 166 Initial development of this policy was supported by a grant from the Perl Foundation.
 167
 168 =head1 AUTHOR
 169
 170 Chris Dolan <cdolan@cpan.org>
 171
 172 =head1 COPYRIGHT
 173
 174 Copyright (c) 2007-2008 Chris Dolan.  Many rights reserved.
 175
 176 This program is free software; you can redistribute it and/or modify
 177 it under the same terms as Perl itself.  The full text of this license
 178 can be found in the LICENSE file included with this module
 179
 180 =cut
 181
 182 # Local Variables:
 183 #   mode: cperl
 184 #   cperl-indent-level: 4
 185 #   fill-column: 78
 186 #   indent-tabs-mode: nil
 187 #   c-indentation-style: bsd
 188 # End:
 189 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :