File Coverage

blib/lib/Perl/Critic/Policy/Subroutines/ProhibitCallsToUnexportedSubs.pm
Criterion Covered Total %
statement 90 98 91.8
branch 17 28 60.7
condition n/a
subroutine 19 21 90.4
pod 5 6 83.3
total 131 153 85.6


line stmt bran cond sub pod time code
1             package Perl::Critic::Policy::Subroutines::ProhibitCallsToUnexportedSubs;
2              
3 1     1   721 use strict;
  1         1  
  1         28  
4 1     1   4 use warnings;
  1         1  
  1         24  
5 1     1   3 use base 'Perl::Critic::Policy';
  1         1  
  1         53  
6              
7 1     1   483 use PPI::Document;
  1         33169  
  1         29  
8 1     1   410 use File::PathList;
  1         467  
  1         28  
9              
10 1         94 use Perl::Critic::Utils qw(
11             :characters
12             :severities
13             &hashify
14             &is_function_call
15             &is_perl_builtin
16             &is_qualified_name
17             &policy_short_name
18 1     1   12 );
  1         1  
19              
20 1         873 use Perl::Critic::StricterSubs::Utils qw{
21             &find_exported_subroutine_names
22             &find_subroutine_calls
23 1     1   284 };
  1         2  
24              
25             #-----------------------------------------------------------------------------
26              
27             our $VERSION = 0.05;
28              
29             #-----------------------------------------------------------------------------
30              
31             my $CONFIG_PATH_SPLIT_REGEX = qr/ \s* [|] \s* /xms;
32              
33             #-----------------------------------------------------------------------------
34              
35             sub supported_parameters {
36 0     0 0 0 return qw( at_inc_prefix use_standard_at_inc at_inc_suffix );
37             }
38              
39 18     18 1 140 sub default_severity { return $SEVERITY_HIGH }
40 0     0 1 0 sub default_themes { return qw( strictersubs bugs ) }
41 5     5 1 47569 sub applies_to { return 'PPI::Document' }
42              
43             #-----------------------------------------------------------------------------
44              
45             sub new {
46 5     5 1 20879 my ( $class, %config ) = @_;
47 5         18 my $self = bless {}, $class;
48              
49 5         6 my @at_inc_prefix;
50             my @at_inc_suffix;
51              
52 5 50       19 if ( defined $config{at_inc_prefix} ) {
53 5         29 @at_inc_prefix =
54             split $CONFIG_PATH_SPLIT_REGEX, $config{at_inc_prefix};
55             }
56 5 50       18 if ( defined $config{at_inc_suffix} ) {
57 0         0 @at_inc_prefix =
58             split $CONFIG_PATH_SPLIT_REGEX, $config{at_inc_suffix};
59             }
60              
61 5         11 my $use_standard_at_inc = $config{use_standard_at_inc};
62 5 50       11 if (not defined $use_standard_at_inc) {
63 5         8 $use_standard_at_inc = 1;
64             }
65              
66 5         10 my @inc = @at_inc_prefix;
67 5 50       14 if ($use_standard_at_inc) {
68 5         24 push @inc, @INC;
69             }
70 5         10 push @inc, @at_inc_suffix;
71              
72 5 50       10 die policy_short_name(__PACKAGE__), " has no directories in its module search path.\n"
73             if not @inc;
74              
75              
76 5         41 $self->{_inc} = File::PathList->new( paths => \@inc, cache => 1 );
77 5         242 $self->{_exports_by_package} = {};
78 5         18 return $self;
79             }
80              
81             #-----------------------------------------------------------------------------
82              
83             sub _get_inc {
84 4     4   9 my $self = shift;
85 4         6 return $self->{_inc};
86             }
87              
88             sub _get_exports_by_package {
89 28     28   35 my $self = shift;
90 28         55 return $self->{_exports_by_package}
91             }
92              
93             #-----------------------------------------------------------------------------
94              
95             sub violates {
96 5     5 1 54 my ($self, undef, $doc) = @_;
97              
98 5         8 my @violations = ();
99 5         9 my $expl = q{Violates encapsulation};
100              
101 5         23 for my $sub_call ( find_subroutine_calls($doc) ) {
102 29 50       1862 next if not is_qualified_name( $sub_call );
103              
104 29         274 my ($package, $sub_name) = $self->_parse_subroutine_call( $sub_call );
105 29 100       59 next if _is_builtin_package( $package );
106              
107 24         53 my $exports = $self->_get_exports_for_package( $package );
108 24 100       51 if ( not exists $exports->{ $sub_name } ){
109              
110 18         32 my $desc = qq{Subroutine "$sub_name" not exported by "$package"};
111 18         59 push @violations, $self->violation( $desc, $expl, $sub_call );
112             }
113              
114             }
115              
116 5         369 return @violations;
117             }
118              
119             #-----------------------------------------------------------------------------
120              
121             sub _parse_subroutine_call {
122 29     29   37 my ($self, $sub_call) = @_;
123 29 50       66 return if not $sub_call;
124              
125 29         34 my $sub_name = $EMPTY;
126 29         30 my $package_name = $EMPTY;
127              
128 29 50       49 if ($sub_call =~ m/ \A &? (.*) :: ([^:]+) \z /xms) {
129 29         224 $package_name = $1;
130 29         38 $sub_name = $2;
131             }
132              
133 29         66 return ($package_name, $sub_name);
134             }
135              
136              
137             #-----------------------------------------------------------------------------
138              
139             sub _get_exports_for_package {
140 24     24   31 my ( $self, $package_name ) = @_;
141              
142 24         45 my $exports = $self->_get_exports_by_package()->{$package_name};
143 24 100       53 if (not $exports) {
144 4         8 $exports = {};
145              
146 4         14 my $file_name =
147             $self->_get_file_name_for_package_name( $package_name );
148              
149 4 50       12 if ($file_name) {
150 4         14 $exports =
151             { hashify ( $self->_get_exports_from_file( $file_name ) ) };
152             }
153              
154 4         1133 $self->_get_exports_by_package()->{$package_name} = $exports;
155             }
156              
157 24         27 return $exports;
158             }
159              
160             #-----------------------------------------------------------------------------
161              
162             sub _get_exports_from_file {
163 4     4   7 my ($self, $file_name) = @_;
164              
165 4         19 my $doc = PPI::Document->new($file_name);
166 4 50       18263 if (not $doc) {
167 0         0 my $pname = policy_short_name(__PACKAGE__);
168 0         0 die "$pname: could not parse $file_name: $PPI::Document::errstr\n";
169             }
170              
171 4         20 return find_exported_subroutine_names( $doc );
172             }
173              
174             #-----------------------------------------------------------------------------
175              
176             sub _get_file_name_for_package_name {
177 4     4   6 my ($self, $package_name) = @_;
178              
179 4         6 my $partial_path = $package_name;
180 4         9 $partial_path =~ s{::}{/}xmsg;
181 4         8 $partial_path .= '.pm';
182              
183 4         11 my $full_path = $self->_find_file_in_at_INC( $partial_path );
184 4         9 return $full_path;
185             }
186              
187             #-----------------------------------------------------------------------------
188              
189             sub _find_file_in_at_INC { ## no critic (NamingConventions::Capitalization)
190 4     4   6 my ($self, $partial_path) = @_;
191              
192 4         10 my $inc = $self->_get_inc();
193 4         20 my $full_path = $inc->find_file( $partial_path );
194              
195 4 50       524 if (not $full_path) {
196             #TODO reinstate Elliot's error message here.
197 0         0 my $policy_name = policy_short_name( __PACKAGE__ );
198 0         0 warn qq{$policy_name: Cannot find source file "$partial_path"\n};
199 0         0 return;
200             }
201              
202 4         9 return $full_path;
203             }
204              
205             #-----------------------------------------------------------------------------
206              
207             my %BUILTIN_PACKAGES = hashify( qw(CORE CORE::GLOBAL UNIVERSAL main), $EMPTY );
208              
209             sub _is_builtin_package {
210 29     29   26 my ($package_name) = @_;
211 29         70 return exists $BUILTIN_PACKAGES{$package_name};
212             }
213              
214             #-----------------------------------------------------------------------------
215              
216             1;
217              
218             __END__
219              
220             =pod
221              
222             =for stopwords callee's
223              
224             =head1 NAME
225              
226             Perl::Critic::Policy::Subroutines::ProhibitCallsToUnexportedSubs
227              
228             =head1 AFFILIATION
229              
230             This policy is part of L<Perl::Critic::StricterSubs|Perl::Critic::StricterSubs>.
231              
232             =head1 DESCRIPTION
233              
234             Many Perl modules define their public interface by exporting subroutines via
235             L<Exporter|Exporter>. The goal of this Policy is to enforce encapsulation by by
236             prohibiting calls to subroutines that are not listed in the callee's C<@EXPORT>
237             or C<@EXPORT_OK>.
238              
239             =head1 LIMITATIONS
240              
241             This Policy does not properly deal with the L<only|only> pragma or modules that
242             don't use L<Exporter|Exporter> for their export mechanism, such as L<CGI|CGI>. In the
243             near future, we might fix this by allowing you configure the policy with
244             a list of packages that are exempt from this policy.
245              
246             =head1 DIAGNOSTICS
247              
248             =over
249              
250             =item C<Subroutines::ProhibitCallsToUnexportedSubs: Cannot find source file>
251              
252             This warning usually indicates that the file under analysis includes modules
253             that are not installed in this perl's <@INC> paths. See L</"CONFIGURATION">
254             for controlling the C<@INC> list this Policy.
255              
256             This warning can also happen when one of the included modules contains
257             multiple packages, or if the package name doesn't match the file name.
258             L<Perl::Critic|Perl::Critic> advises against both of these conditions, and has additional
259             Policies to help enforce that.
260              
261             =back
262              
263             =head1 SEE ALSO
264              
265             L<Perl::Critic::Policy::Modules::ProhibitMultiplePackages|Perl::Critic::Policy::Modules::ProhibitMultiplePackages>
266              
267             L<Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage|Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage>
268              
269             =head1 AUTHOR
270              
271             Jeffrey Ryan Thalhammer <thaljef@cpan.org>
272              
273             =head1 COPYRIGHT
274              
275             Copyright (c) 2007 Jeffrey Ryan Thalhammer. All rights reserved.
276              
277             This program is free software; you can redistribute it and/or modify it under
278             the same terms as Perl itself. The full text of this license can be found in
279             the LICENSE file included with this module.
280              
281             =cut
282              
283              
284             ##############################################################################
285             # Local Variables:
286             # mode: cperl
287             # cperl-indent-level: 4
288             # fill-column: 78
289             # indent-tabs-mode: nil
290             # c-indentation-style: bsd
291             # End:
292             # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab :