File Coverage

blib/lib/Perl/Critic/Policy/Modules/RequireExplicitInclusion.pm
Criterion Covered Total %
statement 75 82 91.4
branch 11 14 78.5
condition 9 11 81.8
subroutine 22 23 95.6
pod 4 5 80.0
total 121 135 89.6


line stmt bran cond sub pod time code
1             package Perl::Critic::Policy::Modules::RequireExplicitInclusion;
2              
3 1     1   167332 use strict;
  1         2  
  1         46  
4 1     1   6 use warnings;
  1         2  
  1         26  
5 1     1   4 use base 'Perl::Critic::Policy';
  1         9  
  1         511  
6              
7 1         63 use Perl::Critic::Utils qw(
8             :characters
9             :severities
10             &hashify
11             &is_class_name
12             &is_function_call
13             &is_perl_builtin
14             &is_qualified_name
15             &policy_short_name
16 1     1   27400 );
  1         3  
17              
18 1         806 use Perl::Critic::StricterSubs::Utils qw(
19             &get_package_names_from_include_statements
20             &get_package_names_from_package_statements
21 1     1   654 );
  1         1  
22              
23             #-----------------------------------------------------------------------------
24              
25             our $VERSION = 0.04;
26              
27             my $expl =
28             'Without importing a package, it is unlikely that references to things inside it even exist.';
29              
30             #-----------------------------------------------------------------------------
31              
32 22     22 0 81516 sub supported_parameters { return }
33 24     24 1 162 sub default_severity { return $SEVERITY_HIGH }
34 0     0 1 0 sub default_themes { return qw( strictersubs bugs ) }
35 22     22 1 149265 sub applies_to { return 'PPI::Document' }
36              
37             #-----------------------------------------------------------------------------
38              
39             sub violates {
40 22     22 1 181 my ($self, undef, $doc) = @_;
41              
42 22         86 my @declared_packages = get_package_names_from_package_statements($doc);
43              
44 22 50       141 if ( @declared_packages > 1 ) {
45 0   0     0 my $fname = $doc->filename() || 'unknown';
46 0         0 my $pname = policy_short_name(__PACKAGE__);
47 0         0 warn qq{$pname: Cannot cope with mutiple packages in file "$fname"\n};
48 0         0 return;
49             }
50              
51 22         64 my @included_packages = get_package_names_from_include_statements($doc);
52 22         250 my @builtin_packages = ( qw(main UNIVERSAL CORE CORE::GLOBAL), $EMPTY );
53              
54 22         81 my %all_packages =
55             hashify( @declared_packages, @included_packages, @builtin_packages );
56              
57 22         270 my @violations = (
58             $self->_find_subroutine_call_violations( $doc, \%all_packages ),
59             $self->_find_class_method_call_violations( $doc, \%all_packages ),
60             $self->_find_symbol_violations( $doc, \%all_packages ),
61             );
62              
63 22         89 return @violations;
64             }
65              
66             #-----------------------------------------------------------------------------
67              
68             sub _find_qualified_subroutine_calls {
69 22     22   21 my $doc = shift;
70              
71             my $calls =
72             $doc->find(
73             sub {
74 973     973   10946 my (undef, $elem) = @_;
75              
76             return
77 973   100     3436 $elem->isa('PPI::Token::Word')
78             && is_qualified_name( $elem->content() )
79             && is_function_call( $elem );
80              
81             }
82 22         116 );
83              
84 22 100       265 return @{$calls} if $calls;
  5         13  
85 17         38 return;
86             }
87              
88             #-----------------------------------------------------------------------------
89              
90             sub _find_class_method_calls {
91 22     22   27 my $doc = shift;
92              
93             my $calls =
94             $doc->find(
95             sub {
96 973     973   10493 my (undef, $elem) = @_;
97              
98             return
99 973   100     3352 $elem->isa('PPI::Token::Word')
100             && is_class_name( $elem )
101             && !is_perl_builtin( $elem )
102             && '__PACKAGE__' ne $elem->content(); # RT 43314, 44609
103             # From a design standpoint we should filter later, but
104             # the violation code is generic. The patch included with
105             # 44609, or adding '__PACKAGE__ to @builtin_packages,
106             # would have also allowed, willy-nilly,
107             # __PACKAGE__::foo() or $__PACKAGE__::foo, neither of
108             # which is correct. So I just hid __PACKAGE__->foo() from
109             # the violation logic. Mea culpa! Tom Wyant
110             }
111 22         110 );
112              
113 22 100       238 return @{$calls} if $calls;
  5         12  
114 17         33 return;
115             }
116              
117             #-----------------------------------------------------------------------------
118              
119             sub _find_qualified_symbols {
120 22     22   27 my $doc = shift;
121              
122             my $symbols =
123             $doc->find(
124             sub {
125 973     973   7503 my (undef, $elem) = @_;
126              
127             return
128 973   100     3550 $elem->isa('PPI::Token::Symbol')
129             && is_qualified_name( $elem->canonical() );
130             }
131 22         96 );
132              
133 22 100       249 return @{$symbols} if $symbols;
  15         34  
134 7         15 return;
135             }
136              
137             #-----------------------------------------------------------------------------
138              
139             sub _extract_package_from_class_method_call {
140              
141             # Class method calls look like "Foo::Bar->baz()"
142             # So the package name will be the entire word,
143             # which should be everything to the left of "->"
144              
145 17     17   17 my $word = shift;
146 17         52 return $word;
147             }
148              
149             #-----------------------------------------------------------------------------
150              
151             sub _extract_package_from_subroutine_call {
152              
153             # Subroutine calls look like "Foo::Bar::baz()"
154             # So the package name will be everything up
155             # to (but not including) the last "::".
156              
157 13     13   12 my $word = shift;
158 13 50       28 if ($word->content() =~ m/\A ( .* ) :: [^:]+ \z/xms) {
159 13         111 return $1;
160             }
161              
162 0         0 return;
163             }
164              
165             #-----------------------------------------------------------------------------
166              
167             sub _extract_package_from_symbol {
168              
169             # Qualified symbols look like "$Foo::Bar::baz"
170             # So the package name will be everything between
171             # the sigil and the last "::".
172              
173 26     26   24 my $symbol = shift;
174 26 50       45 if ($symbol->canonical() =~ m/\A [\$*@%&] ( .* ) :: [^:]+ \z/xms) {
175 26         310 return $1;
176             }
177              
178 0         0 return;
179             }
180              
181             #-----------------------------------------------------------------------------
182              
183             sub _find_violations {
184              
185 66     66   67 my ($self, $doc, $included_packages, $finder, $package_extractor) = @_;
186 66         72 my @violations = ();
187              
188 66         109 for my $call ( $finder->( $doc ) ) {
189 56         1855 my $package = $package_extractor->( $call );
190 56 100       125 next if exists $included_packages->{ $package };
191              
192 24         70 my $desc = qq{Use of "$call" without including "$package"};
193 24         135 push @violations, $self->violation( $desc, $expl, $call );
194             }
195              
196 66         1408 return @violations;
197             }
198              
199             #-----------------------------------------------------------------------------
200              
201             sub _find_subroutine_call_violations {
202 22     22   28 my ($self, $doc, $packages) = @_;
203 22         35 my $finder = \&_find_qualified_subroutine_calls;
204 22         45 my $extractor = \&_extract_package_from_subroutine_call;
205 22         41 return $self->_find_violations( $doc, $packages, $finder, $extractor );
206             }
207              
208             #-----------------------------------------------------------------------------
209              
210             sub _find_class_method_call_violations {
211 22     22   40 my ($self, $doc, $packages) = @_;
212 22         34 my $finder = \&_find_class_method_calls;
213 22         23 my $extractor = \&_extract_package_from_class_method_call;
214 22         34 return $self->_find_violations( $doc, $packages, $finder, $extractor );
215             }
216              
217             #-----------------------------------------------------------------------------
218              
219             sub _find_symbol_violations {
220 22     22   27 my ($self, $doc, $packages) = @_;
221 22         37 my $finder = \&_find_qualified_symbols;
222 22         22 my $extractor = \&_extract_package_from_symbol;
223 22         30 return $self->_find_violations( $doc, $packages, $finder, $extractor );
224             }
225              
226             #-----------------------------------------------------------------------------
227              
228             1;
229              
230             __END__
231              
232             =pod
233              
234             =head1 NAME
235              
236             Perl::Critic::Policy::Modules::RequireExplicitInclusion
237              
238             =head1 AFFILIATION
239              
240             This policy is part of L<Perl::Critic::StricterSubs|Perl::Critic::StricterSubs>.
241              
242             =head1 DESCRIPTION
243              
244             Checks that, if a reference is made to something inside of another
245             package, that a module with the name of the package has been C<use>d
246             or C<require>d.
247              
248             Without importing a package, it is unlikely that references to things
249             inside it even exist. Due to the flexible nature of Perl, C<use
250             strict;> can not complain about references to things outside of the
251             current package and thus won't detect this situation.
252              
253             =head2 Explanation
254              
255             As an example, assume there is a third-party C<Foo> module with a
256             C<bar()> subroutine. You then create a module of your own.
257              
258             package My::Module;
259              
260             ...
261             $x = Foo::bar($y);
262             ...
263              
264             You don't have to worry about whether C<Foo> exports C<bar()> or not
265             because you're fully qualifying the name. Or do you? You then create
266             a program F<plugh> that uses your module that also needs to use C<Foo>
267             directly.
268              
269             #!/usr/bin/perl
270             ...
271             use Foo;
272             use My::Module qw{ &frob };
273             ...
274              
275             This works fine. At some later time, you use your module in a
276             F<xyzzy> program.
277              
278             #!/usr/bin/perl
279             ...
280             use My::Module qw{ &frob };
281             ...
282              
283             You now get compilation problems in the previously robust
284             C<My::Module>. What is going on is that F<plugh> loaded the C<Foo>
285             module prior to C<My::Module>, which means that, when C<My::Module>
286             refers to C<Foo::bar()>, the subroutine actually exists, even though
287             C<My::Module> didn't actually C<use Foo;>. When F<xyzzy> attempted to
288             use C<My::Module> without doing a C<use Foo;>, C<My::Module> fails
289             because C<Foo::bar()> doesn't exist.
290              
291             =head2 Enforcement
292              
293             Assuming that there are no C<use> or C<require> statements within the
294             current scope:
295              
296             @foo = localtime; #ok
297             @Bar::foo = localtime #not ok
298             @::foo = localtime; #ok
299             @main::foo = localtime; #ok
300              
301             baz(23, 'something', $x); #ok
302             Bar::baz(23, 'something', $x); #not ok
303             ::baz(23, 'something', $x); #ok
304             main::baz(23, 'something', $x); #ok
305              
306             Only modules that are symbolically referenced by a C<use> or
307             C<require> are considered valid. Loading a file does not count.
308              
309             use Foo;
310             require Bar;
311             require 'Baz.pm';
312              
313             $Foo:x = 57; #ok
314             $Bar:x = 57; #ok
315             $Baz:x = 57; #not ok
316              
317             Qualifying a name with the name of the current package is valid.
318              
319             package Xyzzy;
320              
321             my $ducks;
322              
323             sub increment_duck_count {
324             $Xyzzy::ducks++; #ok
325             }
326              
327             A C<use> or C<require> statement is taken into account only when it is
328             in the scope of a file or a C<BEGIN>, C<CHECK>, or C<INIT> block.
329              
330             use File::Scope;
331              
332             BEGIN {
333             require Begin::Block;
334             }
335              
336             CHECK {
337             require Check::Block;
338             }
339              
340             INIT {
341             require Init::Block;
342             }
343              
344             END {
345             require End::Block;
346             }
347              
348             push @File::Scope::numbers, 52, 93, 25; #ok
349             push @Begin::Block::numbers, 52, 93, 25; #ok
350             push @Check::Block::numbers, 52, 93, 25; #ok
351             push @Init::Block::numbers, 52, 93, 25; #ok
352             push @End::Block::numbers, 52, 93, 25; #not ok
353              
354             {
355             require Lexical::Block;
356              
357             push @Lexical::Block::numbers, 52, 93, 25; #not ok
358             }
359              
360              
361             =head1 CAVEATS
362              
363             1.) It is assumed that the code for a package exists in a module of
364             the same name.
365              
366              
367             2.) It is assumed that a module will contain no more than one package.
368             This Policy will not complain about any problems in a module
369             containing multiple C<package> statements. For example, a module
370             containing
371              
372             package Foo;
373              
374             sub frob {
375             $Xyzzy::factor = rand 100;
376             }
377              
378             package Bar;
379              
380             sub frob {
381             $Plugh::factor = rand 1000;
382             }
383              
384             will not result in any violations. There really shouldn't be more
385             than one package within a module anyway.
386              
387              
388             3.) No checks of whether the name actually exists in the referenced
389             package are done. E.g., if a call to a C<Foo::process_widgets()>
390             subroutine is made, this Policy does not check that a
391             C<process_widgets()> subroutine actually exists in the C<Foo> package.
392              
393              
394             =head1 CONFIGURATION
395              
396             None.
397              
398             =head1 DIAGNOSTICS
399              
400             =over
401              
402             =item C<Modules::RequireExplicitInclusion: Cannot cope with mutiple packages in file>
403              
404             This warning happens when the file under analysis contains multiple packages,
405             which is not currently supported. This Policy will simply ignore any file
406             with multiple packages.
407              
408             L<Perl::Critic|Perl::Critic> advises putting multiple packages in one file, and has
409             additional Policies to help enforce that.
410              
411             =back
412              
413             =head1 SEE ALSO
414              
415             L<Perl::Critic::Policy::Modules::ProhibitMultiplePackages|Perl::Critic::Policy::Modules::ProhibitMultiplePackages>
416              
417             =head1 AUTHOR
418              
419             Jeffrey Ryan Thalhammer <thaljef@cpan.org>
420              
421             =head1 COPYRIGHT
422              
423             Copyright (c) 2007 Jeffrey Ryan Thalhammer. All rights reserved.
424              
425             This program is free software; you can redistribute it and/or modify it under
426             the same terms as Perl itself. The full text of this license can be found in
427             the LICENSE file included with this module.
428              
429             =cut
430              
431              
432             ##############################################################################
433             # Local Variables:
434             # mode: cperl
435             # cperl-indent-level: 4
436             # fill-column: 78
437             # indent-tabs-mode: nil
438             # c-indentation-style: bsd
439             # End:
440             # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab :