Login
Implement the TODO item P::C::P::Subroutines::ProhibitUnusedPrivateSubroutines.
[gknop/Perl-Critic.git] / lib / Perl / Critic / Policy / Subroutines / ProhibitUnusedPrivateSubroutines.pm
CommitLineData
6ddbc15f
TW
1##############################################################################
2# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/distributions/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/ProhibitUnusedPrivateSubroutines.pm $
3# $Date: 2009-09-07 17:19:21 -0400 (Mon, 07 Sep 2009) $
4# $Author: clonezone $
5# $Revision: 3629 $
6##############################################################################
7
8package Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines;
9
10use 5.006001;
11
12use strict;
13use warnings;
14
15use English qw< $EVAL_ERROR -no_match_vars >;
16use Readonly;
17
18use Perl::Critic::Utils qw{
19 :characters hashify is_function_call is_method_call :severities
20 $EMPTY $TRUE
21};
22use base 'Perl::Critic::Policy';
23
24our $VERSION = '1.105';
25
26#-----------------------------------------------------------------------------
27
28Readonly::Scalar my $DESC =>
29 q{Private subroutine/method '%s' declared but not used};
30Readonly::Scalar my $EXPL => q{Eliminate dead code};
31
32Readonly::Hash my %IS_COMMA => hashify( $COMMA, $FATCOMMA );
33
34#-----------------------------------------------------------------------------
35
36sub supported_parameters {
37 return (
38 {
39 name => 'private_name_regex',
40 description => 'Pattern that determines what a private subroutine is.',
41 default_string => '\b_\w+\b',
42 behavior => 'string',
43 },
44 {
45 name => 'allow',
46 description =>
47 q<Subroutines matching the private name regex to allow under this policy.>,
48 default_string => $EMPTY,
49 behavior => 'string list',
50 },
51 );
52}
53
54sub default_severity { return $SEVERITY_MEDIUM }
55sub default_themes { return qw( core maintenance ) }
56sub applies_to { return 'PPI::Statement::Sub' }
57
58#-----------------------------------------------------------------------------
59
60sub _parse_private_name_regex {
61 my ($self, $parameter, $config_string) = @_;
62
63 my $regex;
64 eval { $regex = qr/$config_string/; 1 } ## no critic (RegularExpressions)
65 or $self->throw_parameter_value_exception(
66 'private_name_regex',
67 $config_string,
68 undef,
69 "is not a valid regular expression: $EVAL_ERROR",
70 );
71
72 $self->__set_parameter_value($parameter, $regex);
73
74 return;
75}
76
77#-----------------------------------------------------------------------------
78
79sub violates {
80 my ( $self, $elem, $document ) = @_;
81
82 # Not interested in forward declarations, only the real thing.
83 $elem->forward() and return;
84
85 # Not interested in subs without names.
86 my $name = $elem->name() or return;
87
88 # If the sub is shoved into someone else's name space, we wimp out.
89 $name =~ m/ :: /smx and return;
90
91 # If the name is explicitly allowed, we just return (OK).
92 $self->{_allow}{$name} and return;
93
94 # If the name is not an anonymous subroutine according to our definition,
95 # we just return (OK).
96 $name =~ m/ \A $self->{_private_name_regex} \z /smx or return;
97
98 # If the subroutine is called in the document, just return (OK).
99 $self->_find_sub_call_in_document( $elem, $document ) and return;
100
101 # If the subroutine is referred to in the document, just return (OK).
102 $self->_find_sub_reference_in_document( $elem, $document ) and return;
103
104 # If the subroutine is used in an overload, just return (OK).
105 $self->_find_sub_overload_in_document( $elem, $document ) and return;
106
107 # No uses of subroutine found. Return a violation.
108 return $self->violation( sprintf( $DESC, $name ), $EXPL, $elem );
109}
110
111
112# Basically the spaceship operator for token locations. The arguments are the
113# two tokens to compare. If either location is unavailable we return undef.
114sub _compare_token_locations {
115 my ( $left_token, $right_token ) = @_;
116 my $left_loc = $left_token->location() or return;
117 my $right_loc = $right_token->location() or return;
118 return $left_loc->[0] <=> $right_loc->[0] ||
119 $left_loc->[1] <=> $right_loc->[1];
120}
121
122# Find out if the subroutine defined in $elem is called in $document. Calls
123# inside the subroutine itself do not count.
124sub _find_sub_call_in_document {
125 my ( $self, $elem, $document ) = @_;
126
127 my $start_token = $elem->first_token();
128 my $finish_token = $elem->last_token();
129 my $name = $elem->name();
130
131 if ( my $found = $document->find( 'PPI::Token::Word' ) ) {
132 foreach my $usage ( @{ $found } ) {
133 $name eq $usage->content() or next;
134 is_function_call( $usage )
135 or is_method_call( $usage )
136 or next;
137 _compare_token_locations( $usage, $start_token ) < 0
138 and return $TRUE;
139 _compare_token_locations( $finish_token, $usage ) < 0
140 and return $TRUE;
141 }
142 }
143
144 return;
145}
146
147# Find out if the subroutine defined in $elem handles an overloaded operator.
148# We recognize both string literals (the usual form) and words (in case
149# someone perversely followed the subroutine name by a fat comma). We ignore
150# the '\&_foo' construction, since _find_sub_reference_in_document() should
151# find this.
152sub _find_sub_overload_in_document {
153 my ( $self, $elem, $document ) = @_;
154
155 my $name = $elem->name();
156
157 if ( my $found = $document->find( 'PPI::Statement::Include' ) ) {
158 foreach my $usage ( @{ $found } ) {
159 'overload' eq $usage->module() or next;
160 my $inx;
161 foreach my $arg ( _get_include_arguments( $usage ) ) {
162 $inx++ % 2 or next;
163 @{ $arg } == 1 or next;
164 my $element = $arg->[0];
165
166 if ( $element->isa( 'PPI::Token::Quote' ) ) {
167 $element->string() eq $name and return $TRUE;
168 } elsif ( $element->isa( 'PPI::Token::Word' ) ) {
169 $element->content() eq $name and return $TRUE;
170 }
171 }
172 }
173 }
174
175 return;
176}
177
178# Find things of the form '&_foo'. This includes both references proper (i.e.
179# '\&foo'), calls using the sigil, and gotos. The latter two do not count if
180# inside the subroutine itself.
181sub _find_sub_reference_in_document {
182 my ( $self, $elem, $document ) = @_;
183
184 my $start_token = $elem->first_token();
185 my $finish_token = $elem->last_token();
186 my $symbol = q<&> . $elem->name();
187
188 if ( my $found = $document->find( 'PPI::Token::Symbol' ) ) {
189 foreach my $usage ( @{ $found } ) {
190 $symbol eq $usage->content() or next;
191
192 my $prior = $usage->sprevious_sibling();
193 defined $prior
194 and $prior->isa( 'PPI::Token::Cast' )
195 and q<\\> eq $prior->content()
196 and return $TRUE;
197
198 is_function_call( $usage )
199 or defined $prior
200 and $prior->isa( 'PPI::Token::Word' )
201 and 'goto' eq $prior->content()
202 or next;
203
204 _compare_token_locations( $usage, $start_token ) < 0
205 and return $TRUE;
206 _compare_token_locations( $finish_token, $usage ) < 0
207 and return $TRUE;
208 }
209 }
210
211 return;
212}
213
214# Expand the given element, losing any brackets along the way. This is
215# intended to be used to flatten the argument list of 'use overload'.
216sub _expand_element {
217 my ( $element ) = @_;
218 $element->isa( 'PPI::Node' )
219 and return ( map { _expand_element( $_ ) } $_->children() );
220 $element->significant() and return $element;
221 return;
222}
223
224# Given an include statement, return its arguments. The return is a flattened
225# list of lists of tokens, each list of tokens representing an argument.
226sub _get_include_arguments {
227 my ($include) = @_;
228
229 # If there are no arguments, just return. We flatten the list because
230 # someone might use parens to define it.
231 my @arguments = map { _expand_element( $_ ) } $include->arguments()
232 or return;
233
234 my @elements;
235 my $inx = 0;
236 foreach my $element ( @arguments ) {
237 if ( $element->isa( 'PPI::Token::Operator' ) &&
238 $IS_COMMA{$element->content()} ) {
239 $inx++;
240 } else {
241 push @{ $elements[$inx] ||= [] }, $element;
242 }
243 }
244
245 return @elements;
246}
247
2481;
249
250__END__
251
252#-----------------------------------------------------------------------------
253
254=pod
255
256=head1 NAME
257
258Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines - Prevent unused private subroutines.
259
260
261=head1 AFFILIATION
262
263This Policy is part of the core L<Perl::Critic|Perl::Critic>
264distribution.
265
266
267=head1 DESCRIPTION
268
269By convention Perl authors (like authors in many other languages)
270indicate private methods and variables by inserting a leading
271underscore before the identifier. This policy catches such subroutines
272which are not used in the file which declares them.
273
274This module defines a 'use' of a subroutine as a subroutine or method call to
275it (other than from inside the subroutine itself), a reference to it (i.e.
276C<< my $foo = \&_foo >>), a C<goto> to it outside the subroutine itself (i.e.
277goto &_foo), or the use of the subroutine's name as an even-numbered argument
278to C<< use overload >>.
279
280
281=head1 CONFIGURATION
282
283You can define what a private subroutine name looks like by specifying
284a regular expression for the C<private_name_regex> option in your
285F<.perlcriticrc>:
286
287 [Subroutines::ProhibitUnusedPrivateSubroutines]
288 private_name_regex = _(?!_)\w+
289
290The above example is a way of saying that subroutines that start with
291a double underscore are not considered to be private. (Perl::Critic,
292in its implementation, uses leading double underscores to indicate a
293distribution-private subroutine -- one that is allowed to be invoked by
294other Perl::Critic modules, but not by anything outside of
295Perl::Critic.)
296
297You can configure additional subroutines to accept by specifying them
298in a space-delimited list to the C<allow> option:
299
300 [Subroutines::ProhibitUnusedPrivateSubroutines]
301 allow = _bar _baz
302
303These are added to the default list of exemptions from this policy. So the
304above allows C<< sub _bar {} >> and C<< sub _baz {} >>, even if they are not
305referred to in the module that defines them.
306
307
308=head1 HISTORY
309
310This policy is derived from
311L<Perl::Critic::Policy::Subroutines::ProtectPrivateSubs|Perl::Critic::Policy::Subroutines::ProtectPrivateSubs>,
312which looks at the other side of the problem.
313
314
315=head1 BUGS
316
317Does not forbid C<< sub Foo::_foo{} >> because it does not know (and can not
318assume) what is in the C<Foo> package.
319
320
321=head1 SEE ALSO
322
323L<Perl::Critic::Policy::Subroutines::ProtectPrivateSubs|Perl::Critic::Policy::Subroutines::ProtectPrivateSubs>.
324
325
326=head1 AUTHOR
327
328Chris Dolan <cdolan@cpan.org>
329
330=head1 COPYRIGHT
331
332Copyright (c) 2009 Thomas R. Wyant, III.
333
334This program is free software; you can redistribute it and/or modify
335it under the same terms as Perl itself. The full text of this license
336can be found in the LICENSE file included with this module.
337
338=cut
339
340# Local Variables:
341# mode: cperl
342# cperl-indent-level: 4
343# fill-column: 78
344# indent-tabs-mode: nil
345# c-indentation-style: bsd
346# End:
347# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :