Login
Implement the TODO item P::C::P::Subroutines::ProhibitUnusedPrivateSubroutines.
authorTom Wyant <harryfmudd@comcast.net>
Sat, 31 Oct 2009 02:28:53 +0000 (02:28 +0000)
committerTom Wyant <harryfmudd@comcast.net>
Sat, 31 Oct 2009 02:28:53 +0000 (02:28 +0000)
This takes the same configuration parameters as
P::C::P::Subroutines::ProtectPrivateSubroutines.

Changes in other modules were self-compliance issues, which were solved by
removing the subroutines that were found in violation (after checking with
'ack' to see if they were truly not referred to!):
  - Perl::Critic::Policy::_get_source_file;
  - Perl::Critic::PolicyConfig::_validate_maximum_violations_per_document;
  - Perl::Critic::Policy::Documentation::PodSpelling::_set_spell_command;
  - Perl::Critic::Policy::NamingConventions::Capitalization::_local_variable.

There appear to be a couple distribution-private subroutines whose names
begin with single underscores:
  - Perl::Critic::PolicyParameter::_get_behavior_values;
  - Perl::Critic::PolicyParameter::_get_description_with_trailing_period.
These were dealt with by adding them to the 'accept' list in
xt/author/40_perlcriticrc-code.

TODO.pod
lib/Perl/Critic/Policy.pm
lib/Perl/Critic/Policy/Documentation/PodSpelling.pm
lib/Perl/Critic/Policy/NamingConventions/Capitalization.pm
lib/Perl/Critic/Policy/Subroutines/ProhibitUnusedPrivateSubroutines.pm [new file with mode: 0644]
lib/Perl/Critic/PolicyConfig.pm
t/Subroutines/ProhibitUnusedPrivateSubroutines.run [new file with mode: 0644]
xt/author/40_perlcriticrc-code

index 9fb75d5..699dd75 100644 (file)
--- a/TODO.pod
+++ b/TODO.pod
@@ -321,21 +321,6 @@ have a separate Policy for each mechanism, and let the user choose
 which one they want to use (I think I prefer the later).
 
 
-=item * Subroutines::ProhibitUnusedPrivateSubroutines
-
-If a file declares
-
-    sub _foo { }
-
-but there's no reference to "_foo" anywhere else in the same file (other than
-a recursive one), this should complain.
-
-For those of us like me who use leading double underscores as a "distribution
-private" indicator, "private" needs to be configurable, like in
-ProtectPrivateSubs.  Maybe we should start thinking about making some of these
-common policy settings global.
-
-
 =item * NamingConventions::ProhibitMisspelledSymbolNames
 
 The idea behind this policy is to encourage better names for variables
index 9c25754..235d7f9 100644 (file)
@@ -507,16 +507,6 @@ sub _format_lack_of_parameter_metadata {
         'Cannot programmatically discover what parameters this policy takes.';
 }
 
-sub _get_source_file {
-    my ($self) = @_;
-
-    my $relative_path =
-        File::Spec->catfile( split m/::/xms, ref $self ) . '.pm';
-
-    return $INC{$relative_path};
-}
-
-
 #-----------------------------------------------------------------------------
 # Apparently, some perls do not implicitly stringify overloading
 # objects before doing a comparison.  This causes a couple of our
index 9736243..475142a 100644 (file)
@@ -144,14 +144,6 @@ sub _get_spell_command {
     return $self->{_spell_command};
 }
 
-sub _set_spell_command {
-    my ( $self, $spell_command ) = @_;
-
-    $self->{_spell_command} = $spell_command;
-
-    return;
-}
-
 #-----------------------------------------------------------------------------
 
 sub _get_spell_command_line {
index a7a3507..052a5ba 100644 (file)
@@ -597,25 +597,6 @@ sub _is_directly_in_scope_block {
     return $prior_to_grand_parent->content() ne 'continue';
 }
 
-sub _local_variable {
-    my ($self, $elem) = @_;
-
-    # The last symbol should be a variable
-    my $n = $elem->snext_sibling() or return 1;
-    my $p = $elem->sprevious_sibling();
-    if ( !$p || $p eq $COMMA ) {
-        # In the middle of a list
-        return 1 if $n eq $COMMA;
-
-        # The first half of an assignment
-        return 1 if $n eq $EQUAL;
-    }
-
-    # Lets say no for know... additional work
-    # should go here.
-    return $EMPTY;
-}
-
 sub _is_not_real_label {
     my $elem = shift;
 
diff --git a/lib/Perl/Critic/Policy/Subroutines/ProhibitUnusedPrivateSubroutines.pm b/lib/Perl/Critic/Policy/Subroutines/ProhibitUnusedPrivateSubroutines.pm
new file mode 100644 (file)
index 0000000..3332dac
--- /dev/null
@@ -0,0 +1,347 @@
+##############################################################################
+#      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/distributions/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/ProhibitUnusedPrivateSubroutines.pm $
+#     $Date: 2009-09-07 17:19:21 -0400 (Mon, 07 Sep 2009) $
+#   $Author: clonezone $
+# $Revision: 3629 $
+##############################################################################
+
+package Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines;
+
+use 5.006001;
+
+use strict;
+use warnings;
+
+use English qw< $EVAL_ERROR -no_match_vars >;
+use Readonly;
+
+use Perl::Critic::Utils qw{
+    :characters hashify is_function_call is_method_call :severities
+    $EMPTY $TRUE
+};
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.105';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC =>
+    q{Private subroutine/method '%s' declared but not used};
+Readonly::Scalar my $EXPL => q{Eliminate dead code};
+
+Readonly::Hash my %IS_COMMA => hashify( $COMMA, $FATCOMMA );
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters {
+    return (
+        {
+            name            => 'private_name_regex',
+            description     => 'Pattern that determines what a private subroutine is.',
+            default_string  => '\b_\w+\b',
+            behavior        => 'string',
+        },
+        {
+            name            => 'allow',
+            description     =>
+                q<Subroutines matching the private name regex to allow under this policy.>,
+            default_string  => $EMPTY,
+            behavior        => 'string list',
+        },
+    );
+}
+
+sub default_severity     { return $SEVERITY_MEDIUM       }
+sub default_themes       { return qw( core maintenance ) }
+sub applies_to           { return 'PPI::Statement::Sub'  }
+
+#-----------------------------------------------------------------------------
+
+sub _parse_private_name_regex {
+    my ($self, $parameter, $config_string) = @_;
+
+    my $regex;
+    eval { $regex = qr/$config_string/; 1 } ## no critic (RegularExpressions)
+        or $self->throw_parameter_value_exception(
+            'private_name_regex',
+            $config_string,
+            undef,
+            "is not a valid regular expression: $EVAL_ERROR",
+        );
+
+    $self->__set_parameter_value($parameter, $regex);
+
+    return;
+}
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+    my ( $self, $elem, $document ) = @_;
+
+    # Not interested in forward declarations, only the real thing.
+    $elem->forward() and return;
+
+    # Not interested in subs without names.
+    my $name = $elem->name() or return;
+
+    # If the sub is shoved into someone else's name space, we wimp out.
+    $name =~ m/ :: /smx and return;
+
+    # If the name is explicitly allowed, we just return (OK).
+    $self->{_allow}{$name} and return;
+
+    # If the name is not an anonymous subroutine according to our definition,
+    # we just return (OK).
+    $name =~ m/ \A $self->{_private_name_regex} \z /smx or return;
+
+    # If the subroutine is called in the document, just return (OK).
+    $self->_find_sub_call_in_document( $elem, $document ) and return;
+
+    # If the subroutine is referred to in the document, just return (OK).
+    $self->_find_sub_reference_in_document( $elem, $document ) and return;
+
+    # If the subroutine is used in an overload, just return (OK).
+    $self->_find_sub_overload_in_document( $elem, $document ) and return;
+
+    # No uses of subroutine found. Return a violation.
+    return $self->violation( sprintf( $DESC, $name ), $EXPL, $elem );
+}
+
+
+# Basically the spaceship operator for token locations. The arguments are the
+# two tokens to compare. If either location is unavailable we return undef.
+sub _compare_token_locations {
+    my ( $left_token, $right_token ) = @_;
+    my $left_loc = $left_token->location() or return;
+    my $right_loc = $right_token->location() or return;
+    return $left_loc->[0] <=> $right_loc->[0] ||
+        $left_loc->[1] <=> $right_loc->[1];
+}
+
+# Find out if the subroutine defined in $elem is called in $document. Calls
+# inside the subroutine itself do not count.
+sub _find_sub_call_in_document {
+    my ( $self, $elem, $document ) = @_;
+
+    my $start_token = $elem->first_token();
+    my $finish_token = $elem->last_token();
+    my $name = $elem->name();
+
+    if ( my $found = $document->find( 'PPI::Token::Word' ) ) {
+        foreach my $usage ( @{ $found } ) {
+            $name eq $usage->content() or next;
+            is_function_call( $usage )
+                or is_method_call( $usage )
+                or next;
+            _compare_token_locations( $usage, $start_token ) < 0
+                and return $TRUE;
+            _compare_token_locations( $finish_token, $usage ) < 0
+                and return $TRUE;
+        }
+    }
+
+    return;
+}
+
+# Find out if the subroutine defined in $elem handles an overloaded operator.
+# We recognize both string literals (the usual form) and words (in case
+# someone perversely followed the subroutine name by a fat comma). We ignore
+# the '\&_foo' construction, since _find_sub_reference_in_document() should
+# find this.
+sub _find_sub_overload_in_document {
+    my ( $self, $elem, $document ) = @_;
+
+    my $name = $elem->name();
+
+    if ( my $found = $document->find( 'PPI::Statement::Include' ) ) {
+        foreach my $usage ( @{ $found } ) {
+            'overload' eq $usage->module() or next;
+            my $inx;
+            foreach my $arg ( _get_include_arguments( $usage ) ) {
+                $inx++ % 2 or next;
+                @{ $arg } == 1 or next;
+                my $element = $arg->[0];
+
+                if ( $element->isa( 'PPI::Token::Quote' ) ) {
+                    $element->string() eq $name and return $TRUE;
+                } elsif ( $element->isa( 'PPI::Token::Word' ) ) {
+                    $element->content() eq $name and return $TRUE;
+                }
+            }
+        }
+    }
+
+    return;
+}
+
+# Find things of the form '&_foo'. This includes both references proper (i.e.
+# '\&foo'), calls using the sigil, and gotos. The latter two do not count if
+# inside the subroutine itself.
+sub _find_sub_reference_in_document {
+    my ( $self, $elem, $document ) = @_;
+
+    my $start_token = $elem->first_token();
+    my $finish_token = $elem->last_token();
+    my $symbol = q<&> . $elem->name();
+
+    if ( my $found = $document->find( 'PPI::Token::Symbol' ) ) {
+        foreach my $usage ( @{ $found } ) {
+            $symbol eq $usage->content() or next;
+
+            my $prior = $usage->sprevious_sibling();
+            defined $prior
+                and $prior->isa( 'PPI::Token::Cast' )
+                and q<\\> eq $prior->content()
+                and return $TRUE;
+
+            is_function_call( $usage )
+                or defined $prior
+                    and $prior->isa( 'PPI::Token::Word' )
+                    and 'goto' eq $prior->content()
+                or next;
+
+            _compare_token_locations( $usage, $start_token ) < 0
+                and return $TRUE;
+            _compare_token_locations( $finish_token, $usage ) < 0
+                and return $TRUE;
+        }
+    }
+
+    return;
+}
+
+# Expand the given element, losing any brackets along the way. This is
+# intended to be used to flatten the argument list of 'use overload'.
+sub _expand_element {
+    my ( $element ) = @_;
+    $element->isa( 'PPI::Node' )
+        and return ( map { _expand_element( $_ ) } $_->children() );
+    $element->significant() and return $element;
+    return;
+}
+
+# Given an include statement, return its arguments. The return is a flattened
+# list of lists of tokens, each list of tokens representing an argument.
+sub _get_include_arguments {
+    my ($include) = @_;
+
+    # If there are no arguments, just return. We flatten the list because
+    # someone might use parens to define it.
+    my @arguments = map { _expand_element( $_ ) } $include->arguments()
+        or return;
+
+    my @elements;
+    my $inx = 0;
+    foreach my $element ( @arguments ) {
+        if ( $element->isa( 'PPI::Token::Operator' ) &&
+            $IS_COMMA{$element->content()} ) {
+            $inx++;
+        } else {
+            push @{ $elements[$inx] ||= [] }, $element;
+        }
+    }
+
+    return @elements;
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines - Prevent unused private subroutines.
+
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic|Perl::Critic>
+distribution.
+
+
+=head1 DESCRIPTION
+
+By convention Perl authors (like authors in many other languages)
+indicate private methods and variables by inserting a leading
+underscore before the identifier.  This policy catches such subroutines
+which are not used in the file which declares them.
+
+This module defines a 'use' of a subroutine as a subroutine or method call to
+it (other than from inside the subroutine itself), a reference to it (i.e.
+C<< my $foo = \&_foo >>), a C<goto> to it outside the subroutine itself (i.e.
+goto &_foo), or the use of the subroutine's name as an even-numbered argument
+to C<< use overload >>.
+
+
+=head1 CONFIGURATION
+
+You can define what a private subroutine name looks like by specifying
+a regular expression for the C<private_name_regex> option in your
+F<.perlcriticrc>:
+
+    [Subroutines::ProhibitUnusedPrivateSubroutines]
+    private_name_regex = _(?!_)\w+
+
+The above example is a way of saying that subroutines that start with
+a double underscore are not considered to be private.  (Perl::Critic,
+in its implementation, uses leading double underscores to indicate a
+distribution-private subroutine -- one that is allowed to be invoked by
+other Perl::Critic modules, but not by anything outside of
+Perl::Critic.)
+
+You can configure additional subroutines to accept by specifying them
+in a space-delimited list to the C<allow> option:
+
+    [Subroutines::ProhibitUnusedPrivateSubroutines]
+    allow = _bar _baz
+
+These are added to the default list of exemptions from this policy. So the
+above allows C<< sub _bar {} >> and C<< sub _baz {} >>, even if they are not
+referred to in the module that defines them.
+
+
+=head1 HISTORY
+
+This policy is derived from
+L<Perl::Critic::Policy::Subroutines::ProtectPrivateSubs|Perl::Critic::Policy::Subroutines::ProtectPrivateSubs>,
+which looks at the other side of the problem.
+
+
+=head1 BUGS
+
+Does not forbid C<< sub Foo::_foo{} >> because it does not know (and can not
+assume) what is in the C<Foo> package.
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::Subroutines::ProtectPrivateSubs|Perl::Critic::Policy::Subroutines::ProtectPrivateSubs>.
+
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2009 Thomas R. Wyant, III.
+
+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 shiftround :
index 48c7b5e..6d55923 100644 (file)
@@ -55,54 +55,6 @@ sub new {
 
 #-----------------------------------------------------------------------------
 
-sub _validate_maximum_violations_per_document {
-    my ($self, $errors) = @_;
-
-    my $user_maximum_violations =
-        $self->get_maximum_violations_per_document();
-
-    if ( defined $user_maximum_violations ) {
-        if (
-                $user_maximum_violations =~ m/$NO_LIMIT/xmsio
-            or  $user_maximum_violations eq $EMPTY
-        ) {
-            $user_maximum_violations = undef;
-        }
-        elsif ( not is_integer($user_maximum_violations) ) {
-            $errors->add_exception(
-                new_parameter_value_exception(
-                    'maximum_violations_per_document',
-                    $user_maximum_violations,
-                    undef,
-                    "does not look like an integer.\n"
-                )
-            );
-
-            return;
-        }
-        elsif ( $user_maximum_violations < 0 ) {
-            $errors->add_exception(
-                new_parameter_value_exception(
-                    'maximum_violations_per_document',
-                    $user_maximum_violations,
-                    undef,
-                    "is not greater than or equal to zero.\n"
-                )
-            );
-
-            return;
-        }
-
-        $self->set_maximum_violations_per_document(
-            $user_maximum_violations
-        );
-    }
-
-    return;
-}
-
-#-----------------------------------------------------------------------------
-
 sub _get_non_public_data {
     my $self = shift;
 
diff --git a/t/Subroutines/ProhibitUnusedPrivateSubroutines.run b/t/Subroutines/ProhibitUnusedPrivateSubroutines.run
new file mode 100644 (file)
index 0000000..7e92d75
--- /dev/null
@@ -0,0 +1,201 @@
+## name basic failure
+## failures 1
+## cut
+
+sub _foo {};
+
+#-----------------------------------------------------------------------------
+
+## name basic pass
+## failures 0
+## cut
+
+sub _foo {};
+_foo;
+
+#-----------------------------------------------------------------------------
+
+## name Method call is OK
+## failures 0
+## cut
+
+sub _foo {};
+$self->_foo();
+
+#-----------------------------------------------------------------------------
+
+## name Method call where invocant is "shift"
+## failures 0
+## cut
+
+sub _foo {};
+shift->_foo;
+
+#-----------------------------------------------------------------------------
+
+## name other builtin-function followed by private method call
+## failures 0
+## cut
+
+sub _foo {};
+pop->_foo();
+
+#-----------------------------------------------------------------------------
+
+## name Maybe non-obvious failure
+## failures 1
+## cut
+
+sub _foo {};
+
+$self->SUPER::_foo();
+
+#-----------------------------------------------------------------------------
+
+## name Forward references do not count
+## failures 0
+## cut
+
+sub _foo;
+
+#-----------------------------------------------------------------------------
+
+## name User-configured exceptions.
+## parms { allow => '_foo _bar _baz' }
+## failures 0
+## cut
+
+sub _foo {};
+sub _bar ($) {};
+sub _baz : method {};
+
+#-----------------------------------------------------------------------------
+
+## name private_name_regex passing
+## failures 0
+## parms { private_name_regex => '_(?!_|parse_)\w+' }
+## cut
+
+sub __foo {};
+sub __bar ($) {};
+sub __baz : method {};
+sub _parse_my_argument {};
+
+#-----------------------------------------------------------------------------
+
+## name private_name_regex failure
+## failures 3
+## parms { private_name_regex => '_(?!_)\w+' }
+## cut
+
+sub _foo {};
+sub _bar ($) {};
+sub _baz : method {};
+
+#-----------------------------------------------------------------------------
+
+## name reference to private subroutine
+## failures 0
+## cut
+
+sub _foo {};
+my $bar = \&_foo;
+
+#-----------------------------------------------------------------------------
+
+## name goto to private subroutine
+## failures 0
+## cut
+
+sub _foo {};
+sub bar {
+    goto &_foo;
+}
+
+#-----------------------------------------------------------------------------
+
+## name private subroutine used in overload
+## failures 0
+## cut
+
+use overload ( cmp => '_compare' );
+sub _compare {};
+
+#-----------------------------------------------------------------------------
+
+## name private subroutine used in overload, the bad way
+## failures 0
+## cut
+
+use overload ( cmp => _compare => foo => 'bar' );
+sub _compare {};
+
+#-----------------------------------------------------------------------------
+
+## name private subroutine used in overload, by reference
+## failures 0
+## cut
+
+use overload ( cmp => \&_compare );
+sub _compare {};
+
+#-----------------------------------------------------------------------------
+
+## name recursive but otherwise unused subroutine
+## failures 2
+## cut
+
+sub _foo {
+    my ( $arg ) = @_;
+    return $arg <= 1 ? $arg : $arg * _foo( $arg - 1 );
+}
+
+sub _bar {
+    --$_[0] > 0 and goto &_bar;
+    return $_[0];
+}
+
+#-----------------------------------------------------------------------------
+
+## name recursive subroutine called outside itself
+## failures 0
+## cut
+
+_foo( 3 );
+sub _foo {
+    my ( $arg ) = @_;
+    return $arg <= 1 ? $arg : $arg * _foo( $arg - 1 );
+}
+
+_bar( 1.3 );
+sub _bar {
+    --$_[0] > 0 and goto &_bar;
+    return $_[0];
+}
+
+#-----------------------------------------------------------------------------
+
+## name subroutine declared in someone else's name space
+## failures 0
+## cut
+
+sub _Foo::_foo {}
+
+#-----------------------------------------------------------------------------
+
+
+##############################################################################
+#      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/distributions/Perl-Critic/t/Subroutines/ProtectPrivateSubs.run $
+#     $Date: 2009-03-01 13:21:29 -0500 (Sun, 01 Mar 2009) $
+#   $Author: clonezone $
+# $Revision: 3194 $
+##############################################################################
+
+# 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 shiftround :
index 96a08a3..9a9bfdb 100644 (file)
@@ -46,6 +46,10 @@ allow_all_brackets = 1
 [RegularExpressions::RequireBracesForMultiline]
 allow_all_brackets = 1
 
+[Subroutines::ProhibitUnusedPrivateSubroutines]
+private_name_regex = _(?!_|parse_)\w+
+allow = _get_behavior_values _get_description_with_trailing_period
+
 [Subroutines::ProtectPrivateSubs]
 private_name_regex = _(?!_)\w+