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