Login
New policy Subroutines::ProhibitManyArgs
authorChris Dolan <chris+github@chrisdolan.net>
Sun, 5 Aug 2007 02:38:16 +0000 (02:38 +0000)
committerChris Dolan <chris+github@chrisdolan.net>
Sun, 5 Aug 2007 02:38:16 +0000 (02:38 +0000)
Changes
MANIFEST
TODO.pod
examples/loadanalysisdb
lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm [new file with mode: 0644]
lib/Perl/Critic/PolicySummary.pod
lib/Perl/Critic/Utils.pm
t/Subroutines/ProhibitManyArgs.run [new file with mode: 0644]

diff --git a/Changes b/Changes
index ec63963..8caa44c 100644 (file)
--- a/Changes
+++ b/Changes
@@ -8,6 +8,7 @@
 [1.xxx]  Released on 2007-xx-xx
 
      New Policies: (funded by a Perl Foundation grant)
+     * Subroutines::ProhibitManyArgs
      * BuiltinFunctions::ProhibitBooleanGrep
      * BuiltinFunctions::ProhibitComplexMappings
      * ValuesAndExpressions::ProhibitImplicitNewlines
index 0354e7a..4b53f21 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -84,6 +84,7 @@ lib/Perl/Critic/Policy/Subroutines/ProhibitAmpersandSigils.pm
 lib/Perl/Critic/Policy/Subroutines/ProhibitBuiltinHomonyms.pm
 lib/Perl/Critic/Policy/Subroutines/ProhibitExcessComplexity.pm
 lib/Perl/Critic/Policy/Subroutines/ProhibitExplicitReturnUndef.pm
+lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm
 lib/Perl/Critic/Policy/Subroutines/ProhibitNestedSubs.pm
 lib/Perl/Critic/Policy/Subroutines/ProhibitSubroutinePrototypes.pm
 lib/Perl/Critic/Policy/Subroutines/ProtectPrivateSubs.pm
@@ -239,6 +240,7 @@ t/Subroutines/ProhibitAmpersandSigils.run
 t/Subroutines/ProhibitBuiltinHomonyms.run
 t/Subroutines/ProhibitExcessComplexity.run
 t/Subroutines/ProhibitExplicitReturnUndef.run
+t/Subroutines/ProhibitManyArgs.run
 t/Subroutines/ProhibitNestedSubs.run
 t/Subroutines/ProhibitSubroutinePrototypes.run
 t/Subroutines/ProtectPrivateSubs.run
index 9a484d0..365ad35 100644 (file)
--- a/TODO.pod
+++ b/TODO.pod
@@ -101,16 +101,6 @@ L<http://www.perlfoundation.org/april_1_2007_new_grant_awards>
 
 =over 4
 
-=item * Subroutines::ProhibitManyArgs (p182)
-
-If first L<PPI::Statement::Variable> is a list C<my>, and @_ is used, make
-sure it's fewer than N elements.  Otherwise make sure there are less than N
-L<PPI::Statement::Variable>s in a row at the beginning which shift @_ or shift
-with no argument.  Furthermore, look for C<$_[\d+]> where C<\d+> is a large
-number.
-
-Crib from Subroutines::RequireArgUnpacking.
-
 =item * InputOutput::RequireChecked* for system calls (p208)
 
 Add policies to ensure checking the return values of system calls.  See
index b0fab6b..00572cb 100755 (executable)
@@ -169,7 +169,7 @@ END_SQL
 }
 
 
-sub execute_insert_statement {
+sub execute_insert_statement {  ##no critic(ProhibitManyArgs)
     my (
         $statement,
         $file_path,
diff --git a/lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm b/lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm
new file mode 100644 (file)
index 0000000..953cb18
--- /dev/null
@@ -0,0 +1,187 @@
+##############################################################################
+#      $URL$
+#     $Date$
+#   $Author$
+# $Revision$
+##############################################################################
+
+package Perl::Critic::Policy::Subroutines::ProhibitManyArgs;
+
+use strict;
+use warnings;
+use Readonly;
+
+use File::Spec;
+use List::Util qw(first);
+use List::MoreUtils qw(uniq any);
+use English qw(-no_match_vars);
+use Carp;
+
+use Perl::Critic::Utils qw{ :booleans :severities &split_nodes_on_comma };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = 1.061;
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DEFAULT_MAX_ARGUMENTS => 5;
+Readonly::Scalar my $AT => q{@}; ##no critic(Interpolation)
+Readonly::Scalar my $AT_ARG => q{@_}; ##no critic(Interpolation)
+
+Readonly::Scalar my $DESC => q{Too many arguments};
+Readonly::Scalar my $EXPL => [182];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return qw(max_arguments) }
+sub default_severity     { return $SEVERITY_MEDIUM         }
+sub default_themes       { return qw( core pbp maintance ) }
+sub applies_to           { return 'PPI::Statement::Sub'    }
+
+#-----------------------------------------------------------------------------
+
+sub initialize_if_enabled {
+    my ($self, $config) = @_;
+
+    #Set configuration if defined
+    $self->{_max_arguments} =
+            defined $config->{max_arguments}
+        &&  $config->{max_arguments} =~ m/(\d+)/xms
+
+            ? $1 : $DEFAULT_MAX_ARGUMENTS;
+
+    return $TRUE;
+}
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+    my ( $self, $elem, undef ) = @_;
+
+    # forward declaration?
+    return if !$elem->block;
+
+    my $num_args;
+    if ($elem->prototype) {
+       # subtract two for the "()" on the prototype 
+       $num_args = -2 + length $elem->prototype;
+    } else {
+       $num_args = _count_args($elem->block->schildren);
+    }
+
+    if ($self->{_max_arguments} < $num_args) {
+       return $self->violation( $DESC, $EXPL, $elem );
+    }
+    return;  # OK
+}
+
+sub _count_args {
+    my @statements = @_;
+
+    # look for these patterns:
+    #    " ... = @_;"    => then examine previous variable list
+    #    " ... = shift;" => counts as one arg, then look for more
+   
+    return 0 if !@statements;  # no statements
+
+    my $statement = shift @statements;
+    my @elements = $statement->schildren();
+    my $operand = pop @elements;
+    while ($operand && $operand->isa('PPI::Token::Structure') && q{;} eq $operand) {
+       $operand = pop @elements;
+    }
+    return 0 if !$operand;
+
+    #print "pulled off last, remaining: '@elements'\n";
+    my $operator = pop @elements;
+    return 0 if !$operator;
+    return 0 if !$operator->isa('PPI::Token::Operator');
+    return 0 if q{=} ne $operator;
+
+    if ($operand->isa('PPI::Token::Magic') && $AT_ARG eq $operand) {
+       return _count_list_elements(@elements);
+    } elsif ($operand->isa('PPI::Token::Word') && 'shift' eq $operand) {
+       return 1 + _count_args(@statements);
+    }
+
+    return 0;
+}
+
+sub _count_list_elements {
+   my @elements = @_;
+
+   my $list = pop @elements;
+   return 0 if !$list;
+   return 0 if !$list->isa('PPI::Structure::List');
+   my @inner = $list->schildren;
+   if (1 == @inner && $inner[0]->isa('PPI::Statement::Expression')) {
+      @inner = $inner[0]->schildren;
+   }
+   return scalar split_nodes_on_comma(@inner);
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=for stopwords refactored
+
+=head1 NAME
+
+Perl::Critic::Policy::Subroutines::ProhibitManyArgs
+
+=head1 DESCRIPTION
+
+Subroutines that expect large numbers of arguments are hard to use
+because programmers routinely have to look at documentation to
+remember the order of those arguments.  Many arguments is often a sign
+that a subroutine should be refactored or that an object should be
+passed to the routine.
+
+=head1 CONFIGURATION
+
+By default, this policy allows up to 5 arguments without warning.  To
+change this threshold, put entries in a F<.perlcriticrc> file like
+this:
+
+  [Subroutines::ProhibitManyArgs]
+  max_arguments = 6
+
+=head1 CAVEATS
+
+PPI doesn't currently detect anonymous subroutines, so we don't check those.
+This should just work when PPI gains that feature.
+
+We don't check for C<@ARG>, the alias for C<@_> from English.pm.  That's
+deprecated anyway.
+
+=head1 CREDITS
+
+Initial development of this policy was supported by a grant from the Perl Foundation.
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007 Chris Dolan.  Many rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.  The full text of this license
+can be found in the LICENSE file included with this module
+
+=cut
+
+# Local Variables:
+#   mode: cperl
+#   cperl-indent-level: 4
+#   fill-column: 78
+#   indent-tabs-mode: nil
+#   c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab :
index 4ec14e1..8c16b8f 100644 (file)
@@ -303,6 +303,10 @@ Return failure with bare C<return> instead of C<return undef> [Severity 5]
 
 C<sub never { sub correct {} }> [Severity 5]
 
+=head2 L<Perl::Critic::Policy::Subroutines::ProhibitManyArgs>
+
+Too many arguments [Severity 3]
+
 =head2 L<Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes>
 
 Don't write C<sub my_function (@@) {}> [Severity 5]
index aefbd7b..8cf5f87 100644 (file)
@@ -90,6 +90,7 @@ Readonly::Array our @EXPORT_OK => qw(
     &precedence_of
     &severity_to_number
     &shebang_line
+    &split_nodes_on_comma
     &verbosity_to_format
     &words_from_string
 );
@@ -815,7 +816,7 @@ sub parse_arg_list {
         #Pull siblings from list
         my $expr = $sib->schild(0);
         return if !$expr;
-        return _split_nodes_on_comma( $expr->schildren() );
+        return split_nodes_on_comma( $expr->schildren() );
     }
     else {
 
@@ -827,13 +828,13 @@ sub parse_arg_list {
             last if $iter->isa('PPI::Token::Structure') and $iter eq $SCOLON;
             push @arg_list, $iter;
         }
-        return  _split_nodes_on_comma( @arg_list );
+        return  split_nodes_on_comma( @arg_list );
     }
 }
 
 #---------------------------------
 
-sub _split_nodes_on_comma {
+sub split_nodes_on_comma {
     my @nodes = @_;
 
     my $i = 0;
@@ -1272,6 +1273,13 @@ nodes.  It's not bullet-proof because it doesn't respect precedence.  In
 general, I don't like the way this function works, so don't count on it to be
 stable (or even present).
 
+=item C<split_nodes_on_comma( @nodes )>
+
+This has the same return type as C<parse_arg_list()> but expects to be passed
+the nodes that represent the interior of a list, like:
+
+  'foo', 1, 2, 'bar'
+
 =item C<is_script( $document )>
 
 Given a L<PPI::Document>, test if it starts with C</#!.*/>.  If so, it is
diff --git a/t/Subroutines/ProhibitManyArgs.run b/t/Subroutines/ProhibitManyArgs.run
new file mode 100644 (file)
index 0000000..ce7fe70
--- /dev/null
@@ -0,0 +1,105 @@
+##############################################################################
+#      $URL$
+#     $Date$
+#   $Author$
+# $Revision$
+##############################################################################
+
+## name basic passes
+## failures 0
+## cut
+
+sub forward;
+
+sub foo {
+   my ($self, $bar) = @_;
+}
+
+sub fu {
+   my $self = shift;
+   my $bar = shift;
+}
+
+sub foo($$) {
+   print $_[0];
+   return;
+}
+
+#-----------------------------------------------------------------------------
+
+## name simple failures
+## failures 3
+## cut
+
+sub foo {
+   my ($self, $bar1, $bar2, $bar3, $bar4, $bar5) = @_;
+}
+
+sub fu {
+   my $self = shift;
+   my $bar1 = shift;
+   my $bar2 = shift;
+   my $bar3 = shift;
+   my $bar4 = shift;
+   my $bar5 = shift;
+}
+
+sub foo($$$$$$) {
+   print $_[0];
+   return;
+}
+
+#-----------------------------------------------------------------------------
+
+## name configured failures
+## failures 3
+## parms {max_arguments => 3}
+## cut
+
+sub foo {
+   my ($self, $bar1, $bar2, $bar3) = @_;
+}
+
+sub fu {
+   my $self = shift;
+   my $bar1 = shift;
+   my $bar2 = shift;
+   my $bar3 = shift;
+}
+
+sub foo($$$$) {
+   print $_[0];
+   return;
+}
+
+#-----------------------------------------------------------------------------
+
+## name configured successes
+## failures 0
+## parms {max_arguments => 3}
+## cut
+
+sub foo_ok {
+   my ($self, $bar1, $bar2) = @_;
+}
+
+sub fu_ok {
+   my $self = shift;
+   my $bar1 = shift;
+   my $bar2 = shift;
+}
+
+sub foo_ok($$$) {
+   print $_[0];
+   return;
+}
+
+#-----------------------------------------------------------------------------
+# Local Variables:
+#   mode: cperl
+#   cperl-indent-level: 4
+#   fill-column: 78
+#   indent-tabs-mode: nil
+#   c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab :