Login
New policy Subroutines::ProhibitManyArgs
[gknop/Perl-Critic.git] / lib / Perl / Critic / Policy / Subroutines / ProhibitManyArgs.pm
CommitLineData
c6e19b74
CD
1##############################################################################
2# $URL$
3# $Date$
4# $Author$
5# $Revision$
6##############################################################################
7
8package Perl::Critic::Policy::Subroutines::ProhibitManyArgs;
9
10use strict;
11use warnings;
12use Readonly;
13
14use File::Spec;
15use List::Util qw(first);
16use List::MoreUtils qw(uniq any);
17use English qw(-no_match_vars);
18use Carp;
19
20use Perl::Critic::Utils qw{ :booleans :severities &split_nodes_on_comma };
21use base 'Perl::Critic::Policy';
22
23our $VERSION = 1.061;
24
25#-----------------------------------------------------------------------------
26
27Readonly::Scalar my $DEFAULT_MAX_ARGUMENTS => 5;
28Readonly::Scalar my $AT => q{@}; ##no critic(Interpolation)
29Readonly::Scalar my $AT_ARG => q{@_}; ##no critic(Interpolation)
30
31Readonly::Scalar my $DESC => q{Too many arguments};
32Readonly::Scalar my $EXPL => [182];
33
34#-----------------------------------------------------------------------------
35
36sub supported_parameters { return qw(max_arguments) }
37sub default_severity { return $SEVERITY_MEDIUM }
38sub default_themes { return qw( core pbp maintance ) }
39sub applies_to { return 'PPI::Statement::Sub' }
40
41#-----------------------------------------------------------------------------
42
43sub initialize_if_enabled {
44 my ($self, $config) = @_;
45
46 #Set configuration if defined
47 $self->{_max_arguments} =
48 defined $config->{max_arguments}
49 && $config->{max_arguments} =~ m/(\d+)/xms
50
51 ? $1 : $DEFAULT_MAX_ARGUMENTS;
52
53 return $TRUE;
54}
55
56#-----------------------------------------------------------------------------
57
58sub violates {
59 my ( $self, $elem, undef ) = @_;
60
61 # forward declaration?
62 return if !$elem->block;
63
64 my $num_args;
65 if ($elem->prototype) {
66 # subtract two for the "()" on the prototype
67 $num_args = -2 + length $elem->prototype;
68 } else {
69 $num_args = _count_args($elem->block->schildren);
70 }
71
72 if ($self->{_max_arguments} < $num_args) {
73 return $self->violation( $DESC, $EXPL, $elem );
74 }
75 return; # OK
76}
77
78sub _count_args {
79 my @statements = @_;
80
81 # look for these patterns:
82 # " ... = @_;" => then examine previous variable list
83 # " ... = shift;" => counts as one arg, then look for more
84
85 return 0 if !@statements; # no statements
86
87 my $statement = shift @statements;
88 my @elements = $statement->schildren();
89 my $operand = pop @elements;
90 while ($operand && $operand->isa('PPI::Token::Structure') && q{;} eq $operand) {
91 $operand = pop @elements;
92 }
93 return 0 if !$operand;
94
95 #print "pulled off last, remaining: '@elements'\n";
96 my $operator = pop @elements;
97 return 0 if !$operator;
98 return 0 if !$operator->isa('PPI::Token::Operator');
99 return 0 if q{=} ne $operator;
100
101 if ($operand->isa('PPI::Token::Magic') && $AT_ARG eq $operand) {
102 return _count_list_elements(@elements);
103 } elsif ($operand->isa('PPI::Token::Word') && 'shift' eq $operand) {
104 return 1 + _count_args(@statements);
105 }
106
107 return 0;
108}
109
110sub _count_list_elements {
111 my @elements = @_;
112
113 my $list = pop @elements;
114 return 0 if !$list;
115 return 0 if !$list->isa('PPI::Structure::List');
116 my @inner = $list->schildren;
117 if (1 == @inner && $inner[0]->isa('PPI::Statement::Expression')) {
118 @inner = $inner[0]->schildren;
119 }
120 return scalar split_nodes_on_comma(@inner);
121}
122
1231;
124
125__END__
126
127#-----------------------------------------------------------------------------
128
129=pod
130
131=for stopwords refactored
132
133=head1 NAME
134
135Perl::Critic::Policy::Subroutines::ProhibitManyArgs
136
137=head1 DESCRIPTION
138
139Subroutines that expect large numbers of arguments are hard to use
140because programmers routinely have to look at documentation to
141remember the order of those arguments. Many arguments is often a sign
142that a subroutine should be refactored or that an object should be
143passed to the routine.
144
145=head1 CONFIGURATION
146
147By default, this policy allows up to 5 arguments without warning. To
148change this threshold, put entries in a F<.perlcriticrc> file like
149this:
150
151 [Subroutines::ProhibitManyArgs]
152 max_arguments = 6
153
154=head1 CAVEATS
155
156PPI doesn't currently detect anonymous subroutines, so we don't check those.
157This should just work when PPI gains that feature.
158
159We don't check for C<@ARG>, the alias for C<@_> from English.pm. That's
160deprecated anyway.
161
162=head1 CREDITS
163
164Initial development of this policy was supported by a grant from the Perl Foundation.
165
166=head1 AUTHOR
167
168Chris Dolan <cdolan@cpan.org>
169
170=head1 COPYRIGHT
171
172Copyright (c) 2007 Chris Dolan. Many rights reserved.
173
174This program is free software; you can redistribute it and/or modify
175it under the same terms as Perl itself. The full text of this license
176can be found in the LICENSE file included with this module
177
178=cut
179
180# Local Variables:
181# mode: cperl
182# cperl-indent-level: 4
183# fill-column: 78
184# indent-tabs-mode: nil
185# c-indentation-style: bsd
186# End:
187# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab :