Login
RT #61311: Subroutines::ProhibitUnusedPrivateSubroutines dies on
[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
e7bc8e2b 24our $VERSION = '1.110';
6ddbc15f
TW
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
91f5a3cd
TW
147 foreach my $regexp ( _find_regular_expressions( $document ) ) {
148
149 _compare_token_locations( $regexp, $start_token ) >= 0
150 and _compare_token_locations( $finish_token, $regexp ) >= 0
151 and next;
f79ca4e8 152 _find_sub_usage_in_regexp( $name, $regexp, $document )
91f5a3cd
TW
153 and return $TRUE;
154
155 }
156
157 return;
158}
159
160# Find analyzable regular expressions in the given document. This means
161# matches, substitutions, and the qr{} operator.
162sub _find_regular_expressions {
163 my ( $document ) = @_;
164
91f5a3cd
TW
165 return ( map { @{ $document->find( $_ ) || [] } } qw{
166 PPI::Token::Regexp::Match
167 PPI::Token::Regexp::Substitute
168 PPI::Token::QuoteLike::Regexp
169 } );
170}
171
172# Find out if the subroutine named in $name is called in the given $regexp.
173# This could happen either by an explicit s/.../.../e, or by interpolation
174# (i.e. @{[...]} ).
175sub _find_sub_usage_in_regexp {
f79ca4e8 176 my ( $name, $regexp, $document ) = @_;
91f5a3cd 177
f79ca4e8
TW
178 my $ppix = $document->ppix_regexp_from_element( $regexp ) or return;
179 $ppix->failures() and return;
91f5a3cd
TW
180
181 foreach my $code ( @{ $ppix->find( 'PPIx::Regexp::Token::Code' ) || [] } ) {
182 my $doc = $code->ppi() or next;
183
184 foreach my $word ( @{ $doc->find( 'PPI::Token::Word' ) || [] } ) {
185 $name eq $word->content() or next;
186 is_function_call( $word )
187 or is_method_call( $word )
188 or next;
189 return $TRUE;
190 }
191
192 }
193
6ddbc15f
TW
194 return;
195}
196
197# Find out if the subroutine defined in $elem handles an overloaded operator.
198# We recognize both string literals (the usual form) and words (in case
199# someone perversely followed the subroutine name by a fat comma). We ignore
200# the '\&_foo' construction, since _find_sub_reference_in_document() should
201# find this.
202sub _find_sub_overload_in_document {
203 my ( $self, $elem, $document ) = @_;
204
205 my $name = $elem->name();
206
207 if ( my $found = $document->find( 'PPI::Statement::Include' ) ) {
208 foreach my $usage ( @{ $found } ) {
209 'overload' eq $usage->module() or next;
210 my $inx;
211 foreach my $arg ( _get_include_arguments( $usage ) ) {
212 $inx++ % 2 or next;
213 @{ $arg } == 1 or next;
214 my $element = $arg->[0];
215
216 if ( $element->isa( 'PPI::Token::Quote' ) ) {
217 $element->string() eq $name and return $TRUE;
218 } elsif ( $element->isa( 'PPI::Token::Word' ) ) {
219 $element->content() eq $name and return $TRUE;
220 }
221 }
222 }
223 }
224
225 return;
226}
227
228# Find things of the form '&_foo'. This includes both references proper (i.e.
229# '\&foo'), calls using the sigil, and gotos. The latter two do not count if
230# inside the subroutine itself.
231sub _find_sub_reference_in_document {
232 my ( $self, $elem, $document ) = @_;
233
234 my $start_token = $elem->first_token();
235 my $finish_token = $elem->last_token();
236 my $symbol = q<&> . $elem->name();
237
238 if ( my $found = $document->find( 'PPI::Token::Symbol' ) ) {
239 foreach my $usage ( @{ $found } ) {
240 $symbol eq $usage->content() or next;
241
242 my $prior = $usage->sprevious_sibling();
2e31b804 243 $prior
6ddbc15f
TW
244 and $prior->isa( 'PPI::Token::Cast' )
245 and q<\\> eq $prior->content()
246 and return $TRUE;
247
248 is_function_call( $usage )
2e31b804 249 or $prior
6ddbc15f
TW
250 and $prior->isa( 'PPI::Token::Word' )
251 and 'goto' eq $prior->content()
252 or next;
253
254 _compare_token_locations( $usage, $start_token ) < 0
255 and return $TRUE;
256 _compare_token_locations( $finish_token, $usage ) < 0
257 and return $TRUE;
258 }
259 }
260
261 return;
262}
263
264# Expand the given element, losing any brackets along the way. This is
265# intended to be used to flatten the argument list of 'use overload'.
266sub _expand_element {
267 my ( $element ) = @_;
268 $element->isa( 'PPI::Node' )
269 and return ( map { _expand_element( $_ ) } $_->children() );
270 $element->significant() and return $element;
271 return;
272}
273
274# Given an include statement, return its arguments. The return is a flattened
275# list of lists of tokens, each list of tokens representing an argument.
276sub _get_include_arguments {
277 my ($include) = @_;
278
279 # If there are no arguments, just return. We flatten the list because
280 # someone might use parens to define it.
281 my @arguments = map { _expand_element( $_ ) } $include->arguments()
282 or return;
283
284 my @elements;
285 my $inx = 0;
286 foreach my $element ( @arguments ) {
287 if ( $element->isa( 'PPI::Token::Operator' ) &&
288 $IS_COMMA{$element->content()} ) {
289 $inx++;
290 } else {
291 push @{ $elements[$inx] ||= [] }, $element;
292 }
293 }
294
295 return @elements;
296}
297
2981;
299
300__END__
301
302#-----------------------------------------------------------------------------
303
304=pod
305
306=head1 NAME
307
308Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines - Prevent unused private subroutines.
309
310
311=head1 AFFILIATION
312
313This Policy is part of the core L<Perl::Critic|Perl::Critic>
314distribution.
315
316
317=head1 DESCRIPTION
318
319By convention Perl authors (like authors in many other languages)
320indicate private methods and variables by inserting a leading
321underscore before the identifier. This policy catches such subroutines
322which are not used in the file which declares them.
323
324This module defines a 'use' of a subroutine as a subroutine or method call to
325it (other than from inside the subroutine itself), a reference to it (i.e.
326C<< my $foo = \&_foo >>), a C<goto> to it outside the subroutine itself (i.e.
800a02ca
ES
327C<goto &_foo>), or the use of the subroutine's name as an even-numbered
328argument to C<< use overload >>.
6ddbc15f
TW
329
330
331=head1 CONFIGURATION
332
333You can define what a private subroutine name looks like by specifying
334a regular expression for the C<private_name_regex> option in your
335F<.perlcriticrc>:
336
337 [Subroutines::ProhibitUnusedPrivateSubroutines]
338 private_name_regex = _(?!_)\w+
339
340The above example is a way of saying that subroutines that start with
341a double underscore are not considered to be private. (Perl::Critic,
342in its implementation, uses leading double underscores to indicate a
343distribution-private subroutine -- one that is allowed to be invoked by
344other Perl::Critic modules, but not by anything outside of
345Perl::Critic.)
346
347You can configure additional subroutines to accept by specifying them
348in a space-delimited list to the C<allow> option:
349
350 [Subroutines::ProhibitUnusedPrivateSubroutines]
351 allow = _bar _baz
352
353These are added to the default list of exemptions from this policy. So the
354above allows C<< sub _bar {} >> and C<< sub _baz {} >>, even if they are not
355referred to in the module that defines them.
356
357
358=head1 HISTORY
359
360This policy is derived from
361L<Perl::Critic::Policy::Subroutines::ProtectPrivateSubs|Perl::Critic::Policy::Subroutines::ProtectPrivateSubs>,
362which looks at the other side of the problem.
363
364
365=head1 BUGS
366
367Does not forbid C<< sub Foo::_foo{} >> because it does not know (and can not
368assume) what is in the C<Foo> package.
369
370
371=head1 SEE ALSO
372
373L<Perl::Critic::Policy::Subroutines::ProtectPrivateSubs|Perl::Critic::Policy::Subroutines::ProtectPrivateSubs>.
374
375
376=head1 AUTHOR
377
378Chris Dolan <cdolan@cpan.org>
379
380=head1 COPYRIGHT
381
072692c8 382Copyright (c) 2009-2010 Thomas R. Wyant, III.
6ddbc15f
TW
383
384This program is free software; you can redistribute it and/or modify
385it under the same terms as Perl itself. The full text of this license
386can be found in the LICENSE file included with this module.
387
388=cut
389
390# Local Variables:
391# mode: cperl
392# cperl-indent-level: 4
393# fill-column: 78
394# indent-tabs-mode: nil
395# c-indentation-style: bsd
396# End:
397# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :