File Coverage

blib/lib/Module/Extract/Namespaces.pm
Criterion Covered Total %
statement 88 97 90.7
branch 17 24 70.8
condition 2 2 100.0
subroutine 24 24 100.0
pod 11 11 100.0
total 142 158 89.8


line stmt bran cond sub pod time code
1 3     3   1957 use 5.008;
  3         9  
2              
3             package Module::Extract::Namespaces;
4 3     3   14 use strict;
  3         5  
  3         70  
5              
6 3     3   15 use warnings;
  3         5  
  3         81  
7 3     3   29 no warnings;
  3         5  
  3         172  
8              
9             our $VERSION = '1.023';
10              
11 3     3   17 use Carp qw(croak);
  3         5  
  3         158  
12 3     3   802 use File::Spec::Functions qw(splitdir catfile);
  3         1396  
  3         166  
13 3     3   1347 use PPI 1.126;
  3         277083  
  3         2367  
14              
15             =encoding utf8
16              
17             =head1 NAME
18              
19             Module::Extract::Namespaces - extract the package declarations from a module
20              
21             =head1 SYNOPSIS
22              
23             use Module::Extract::Namespaces;
24              
25             # in scalar context, extract first package namespace
26             my $namespace = Module::Extract::Namespaces->from_file( $filename );
27             if( Module::Extract::Namespaces->error ) { ... }
28              
29             # in list context, extract all namespaces
30             my @namespaces = Module::Extract::Namespaces->from_file( $filename );
31             if( Module::Extract::Namespaces->error ) { ... }
32              
33             # can do the Perl 5.12 package syntax with possible versions
34             # in list context, extract all namespaces and versions as duples
35             my @namespaces = Module::Extract::Namespaces->from_file( $filename, 1 );
36             if( Module::Extract::Namespaces->error ) { ... }
37              
38              
39             =head1 DESCRIPTION
40              
41             This module extracts package declarations from Perl code without
42             running the code.
43              
44             It does not extract:
45              
46             =over 4
47              
48             =item * packages declared dynamically (e.g. in C)
49              
50             =item * packages created as part of a fully qualified variable name
51              
52             =back
53              
54             =head2 Class methods
55              
56             =over 4
57              
58             =item from_module( MODULE, [ @DIRS ] )
59              
60             Extract the namespaces declared in MODULE. In list context, it returns
61             all of the namespaces, including possible duplicates. In scalar
62             context it returns the first declared namespace.
63              
64             You can specify a list of directories to search for the module. If you
65             don't, it uses C<@INC> by default.
66              
67             If it cannot find MODULE, it returns undef in scalar context and the
68             empty list in list context.
69              
70             On failure it returns nothing, but you have to check with C to
71             see if that is really an error or a file with no namespaces in it.
72              
73             =cut
74              
75             sub from_module {
76 2     2 1 7930 my( $class, $module, @dirs ) = @_;
77              
78 2 50       9 @dirs = @INC unless @dirs;
79 2         10 $class->_clear_error;
80              
81 2         6 my $absolute_path = $class->_module_to_file( $module, @dirs );
82 2 50       6 unless( defined $absolute_path ) {
83 0         0 $class->_set_error( "Did not find module [$module] in [@dirs]!" );
84 0         0 return;
85             }
86              
87 2 100       5 if( wantarray ) { my @a = $class->from_file( $absolute_path ) }
  1         5  
88 1         3 else { scalar $class->from_file( $absolute_path ) }
89             }
90              
91             sub _module_to_file {
92 2     2   5 my( $class, $module, @dirs ) = @_;
93              
94 2         14 my @module_parts = split /\b(?:::|')\b/, $module;
95 2         7 $module_parts[-1] .= '.pm';
96              
97 2         6 foreach my $dir ( @dirs ) {
98 2 50       39 unless( -d $dir ) {
99 0         0 carp( "The path [$dir] does not appear to be a directory" );
100 0         0 next;
101             }
102 2         13 my @dir_parts = splitdir( $dir );
103 2         43 my $path = catfile( @dir_parts, @module_parts );
104 2 50       30 next unless -e $path;
105 2         17 return $path;
106             }
107              
108 0         0 return;
109             }
110              
111             =item from_file( FILENAME [,WITH_VERSIONS] )
112              
113             Extract the namespaces declared in FILENAME. In list context, it
114             returns all of the namespaces, including possible duplicates. In
115             scalar context it returns the first declared namespace.
116              
117             If FILENAME does not exist, it returns undef in scalar context and the
118             empty list in list context.
119              
120             On failure it returns nothing, but you have to check with C to
121             see if that is really an error or a file with no namespaces in it.
122              
123             =cut
124              
125             sub from_file {
126 11     11 1 14176 my( $class, $file, $with_versions ) = @_;
127              
128 11         36 $class->_clear_error;
129              
130 11 100       149 unless( -e $file ) {
131 1         10 $class->_set_error( "File [$file] does not exist!" );
132 1         5 return;
133             }
134              
135 10         39 my $Document = $class->get_pdom( $file );
136 10 50       31 unless( $Document ) {
137 0         0 return;
138             }
139              
140 10 100       32 my $method = $with_versions ?
141             'get_namespaces_and_versions_from_pdom'
142             :
143             'get_namespaces_from_pdom'
144             ;
145              
146 10         36 my @namespaces = $class->$method( $Document );
147              
148 10 100       24 if( wantarray ) { @namespaces }
  8         60  
149 2         12 else { $namespaces[0] }
150             }
151              
152              
153             =back
154              
155             =head2 Subclassable hooks
156              
157             =over 4
158              
159             =item $class->pdom_base_class()
160              
161             Return the base class for the PDOM. This is C by default. If you
162             want to use something else, you'll have to change all the other PDOM
163             methods to adapt to the different interface.
164              
165             This is the class name to use with C to load the module that
166             while handle the parsing.
167              
168             =cut
169              
170 10     10 1 19 sub pdom_base_class { 'PPI' }
171              
172             =item $class->pdom_document_class()
173              
174             Return the class name to use to create the PDOM object. This is
175             C.
176              
177             =cut
178              
179              
180 10     10 1 21 sub pdom_document_class { 'PPI::Document' }
181              
182             =item get_pdom( FILENAME )
183              
184             Creates the PDOM from FILENAME. This depends on calls to
185             C and C.
186              
187             =cut
188              
189             sub get_pdom {
190 10     10 1 26 my( $class, $file ) = @_;
191              
192 10         23 my $pdom_class = $class->pdom_base_class;
193              
194 10         612 eval "require $pdom_class; 1";
195              
196 10         26 my $Document = eval {
197 10         30 my $pdom_document_class = $class->pdom_document_class;
198              
199 10         47 my $d = $pdom_document_class->new( $file );
200 10 50       172099 die $pdom_document_class->errstr unless $d;
201              
202 10         64 $class->pdom_preprocess( $d );
203 10         33 $d;
204             };
205              
206 10 50       37 if( $@ ) {
207 0         0 $class->_set_error( "Could not get PDOM for $file: $@" );
208 0         0 return;
209             }
210              
211 10         23 $Document;
212             }
213              
214             =item $class->pdom_preprocess( PDOM )
215              
216             Override this method to play with the PDOM before extracting the
217             package declarations.
218              
219             By default, it strips Pod and comments from the PDOM.
220              
221             =cut
222              
223             sub pdom_preprocess {
224 10     10 1 22 my( $class, $Document ) = @_;
225              
226 10         15 eval {
227 10         31 $class->pdom_strip_pod( $Document );
228 10         35634 $class->pdom_strip_comments( $Document );
229             };
230              
231 10         32963 return 1;
232             }
233              
234             =item $class->pdom_strip_pod( PDOM )
235              
236             Strips Pod documentation from the PDOM.
237              
238             =cut
239              
240 10     10 1 60 sub pdom_strip_pod { $_[1]->prune('PPI::Token::Pod') }
241              
242             =item $class->pdom_strip_comments( PDOM )
243              
244             Strips comments from the PDOM.
245              
246             =cut
247              
248 10     10 1 38 sub pdom_strip_comments { $_[1]->prune('PPI::Token::Comment') }
249              
250             =item $class->get_namespaces_from_pdom( PDOM )
251              
252             Extract the namespaces from the PDOM. It returns a list of package
253             names in the order that it finds them in the PDOM. It does not
254             remove duplicates (do that later if you like).
255              
256             =cut
257              
258             sub get_namespaces_from_pdom {
259 9     9 1 25 my( $class, $Document ) = @_;
260              
261 9         29 my @array = $class->_get_namespaces_from_pdom( $Document );
262 9         17 map { $_->[0] } @array;
  17         50  
263             }
264              
265             =item $class->get_namespaces_and_versions_from_pdom( PDOM )
266              
267             This extracts version information if the package statement uses the
268             Perl 5.12 syntax:
269              
270             package NAME VERSION BLOCK
271              
272             Extract the namespaces from the PDOM. It returns a list anonymous
273             arrays of package names and versions in the order that it finds them
274             in the PDOM. It does not remove duplicates (do that later if you like).
275              
276             =cut
277              
278             sub get_namespaces_and_versions_from_pdom {
279 1     1 1 3 my( $class, $Document ) = @_;
280              
281 1         5 my @array = $class->_get_namespaces_from_pdom( $Document );
282             }
283              
284             sub _get_namespaces_from_pdom {
285 10     10   50 my( $class, $Document ) = @_;
286              
287             my $package_statements = $Document->find(
288             sub {
289             $_[1]->isa('PPI::Statement::Package')
290             ?
291 1689 100   1689   15618 defined eval { $_[1]->namespace }
  21         53  
292             :
293             0
294             }
295 10   100     66 ) || [];
296              
297 10         136 my @namespaces = eval {
298             map {
299             # $1 $2
300 10         31 /package \s+ (\w+(?:::\w+)*) (?:\s* (\S+))? \s* (?:;|\{) /x;
  21         56  
301 21         825 [ $1, $2 ]
302             } @$package_statements
303             };
304              
305             #print STDERR "Got namespaces @namespaces\n";
306              
307 10         28 @namespaces;
308             }
309              
310             =item $class->error
311              
312             Return the error from the last call to C.
313              
314             =cut
315              
316 0         0 BEGIN {
317 3     3   106 my $Error = '';
318              
319 1     1   2 sub _set_error { $Error = $_[1]; }
320              
321 13     13   22 sub _clear_error { $Error = '' }
322              
323 8     8 1 1577 sub error { $Error }
324             }
325              
326             =back
327              
328             =head1 TO DO
329              
330             * Add caching based on file digest?
331              
332             =head1 SOURCE AVAILABILITY
333              
334             This code is in Github:
335              
336             http://github.com/briandfoy/module-extract-namespaces
337              
338             =head1 AUTHOR
339              
340             brian d foy, C<< >>
341              
342             This module was partially funded by The Perl Foundation
343             (www.perlfoundation.org) and LogicLAB (www.logiclab.dk), both of whom
344             provided travel assistance to the 2008 Oslo QA Hackathon where I
345             created this module.
346              
347             =head1 COPYRIGHT AND LICENSE
348              
349             Copyright © 2008-2022, brian d foy . All rights reserved.
350              
351             You may redistribute this under the Artistic License 2.0.
352              
353             =cut
354              
355             1;