Commit | Line | Data |
bb4e9162 |
1 | package Module::Build::ModuleInfo; |
2 | |
3 | # This module provides routines to gather information about |
4 | # perl modules (assuming this may be expanded in the distant |
5 | # parrot future to look at other types of modules). |
6 | |
7 | use strict; |
8 | |
9 | use File::Spec; |
10 | use IO::File; |
11 | |
12 | |
13 | my $PKG_REGEXP = qr/ # match a package declaration |
14 | ^[\s\{;]* # intro chars on a line |
15 | package # the word 'package' |
16 | \s+ # whitespace |
17 | ([\w:]+) # a package name |
18 | \s* # optional whitespace |
19 | ; # semicolon line terminator |
20 | /x; |
21 | |
22 | my $VARNAME_REGEXP = qr/ # match fully-qualified VERSION name |
23 | ([\$*]) # sigil - $ or * |
24 | ( |
25 | ( # optional leading package name |
26 | (?:::|\')? # possibly starting like just :: (ala $::VERSION) |
27 | (?:\w+(?:::|\'))* # Foo::Bar:: ... |
28 | )? |
29 | VERSION |
30 | )\b |
31 | /x; |
32 | |
33 | my $VERS_REGEXP = qr/ # match a VERSION definition |
34 | (?: |
35 | \(\s*$VARNAME_REGEXP\s*\) # with parens |
36 | | |
37 | $VARNAME_REGEXP # without parens |
38 | ) |
39 | \s* |
40 | =[^=~] # = but not ==, nor =~ |
41 | /x; |
42 | |
43 | |
44 | sub new_from_file { |
45 | my $package = shift; |
46 | my $filename = File::Spec->rel2abs( shift ); |
47 | return undef unless defined( $filename ) && -f $filename; |
48 | return $package->_init( undef, $filename, @_ ); |
49 | } |
50 | |
51 | sub new_from_module { |
52 | my $package = shift; |
53 | my $module = shift; |
54 | my %props = @_; |
55 | $props{inc} ||= \@INC; |
56 | my $filename = $package->find_module_by_name( $module, $props{inc} ); |
57 | return undef unless defined( $filename ) && -f $filename; |
58 | return $package->_init( $module, $filename, %props ); |
59 | } |
60 | |
61 | sub _init { |
62 | my $package = shift; |
63 | my $module = shift; |
64 | my $filename = shift; |
65 | |
66 | my %props = @_; |
67 | my( %valid_props, @valid_props ); |
68 | @valid_props = qw( collect_pod inc ); |
69 | @valid_props{@valid_props} = delete( @props{@valid_props} ); |
70 | warn "Unknown properties: @{[keys %props]}\n" if scalar( %props ); |
71 | |
72 | my %data = ( |
73 | module => $module, |
74 | filename => $filename, |
75 | version => undef, |
76 | packages => [], |
77 | versions => {}, |
78 | pod => {}, |
79 | pod_headings => [], |
80 | collect_pod => 0, |
81 | |
82 | %valid_props, |
83 | ); |
84 | |
85 | my $self = bless( \%data, $package ); |
86 | |
87 | $self->_parse_file(); |
88 | |
89 | unless ( $self->{module} && length( $self->{module} ) ) { |
90 | my( $v, $d, $f ) = File::Spec->splitpath( $self->{filename} ); |
91 | if ( $f =~ /\.pm$/ ) { |
92 | $f =~ s/\..+$//; |
93 | my @candidates = grep /$f$/, @{$self->{packages}}; |
94 | $self->{module} = shift( @candidates ); # punt |
95 | } else { |
96 | if ( grep /main/, @{$self->{packages}} ) { |
97 | $self->{module} = 'main'; |
98 | } else { |
99 | $self->{module} = $self->{packages}[0] || ''; |
100 | } |
101 | } |
102 | } |
103 | |
104 | $self->{version} = $self->{versions}{$self->{module}} |
105 | if defined( $self->{module} ); |
106 | |
107 | return $self; |
108 | } |
109 | |
110 | # class method |
111 | sub _do_find_module { |
112 | my $package = shift; |
113 | my $module = shift || die 'find_module_by_name() requires a package name'; |
114 | my $dirs = shift || \@INC; |
115 | |
116 | my $file = File::Spec->catfile(split( /::/, $module)); |
117 | foreach my $dir ( @$dirs ) { |
118 | my $testfile = File::Spec->catfile($dir, $file); |
119 | return [ File::Spec->rel2abs( $testfile ), $dir ] |
120 | if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp |
121 | return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ] |
122 | if -e "$testfile.pm"; |
123 | } |
124 | return; |
125 | } |
126 | |
127 | # class method |
128 | sub find_module_by_name { |
129 | my $found = shift()->_do_find_module(@_) or return; |
130 | return $found->[0]; |
131 | } |
132 | |
133 | # class method |
134 | sub find_module_dir_by_name { |
135 | my $found = shift()->_do_find_module(@_) or return; |
136 | return $found->[1]; |
137 | } |
138 | |
139 | |
140 | # given a line of perl code, attempt to parse it if it looks like a |
141 | # $VERSION assignment, returning sigil, full name, & package name |
142 | sub _parse_version_expression { |
143 | my $self = shift; |
144 | my $line = shift; |
145 | |
146 | my( $sig, $var, $pkg ); |
147 | if ( $line =~ $VERS_REGEXP ) { |
148 | ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 ); |
149 | if ( $pkg ) { |
150 | $pkg = ($pkg eq '::') ? 'main' : $pkg; |
151 | $pkg =~ s/::$//; |
152 | } |
153 | } |
154 | |
155 | return ( $sig, $var, $pkg ); |
156 | } |
157 | |
158 | sub _parse_file { |
159 | my $self = shift; |
160 | |
161 | my $filename = $self->{filename}; |
162 | my $fh = IO::File->new( $filename ) |
163 | or die( "Can't open '$filename': $!" ); |
164 | |
165 | my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 ); |
166 | my( @pkgs, %vers, %pod, @pod ); |
167 | my $pkg = 'main'; |
168 | my $pod_sect = ''; |
169 | my $pod_data = ''; |
170 | |
171 | while (defined( my $line = <$fh> )) { |
172 | |
173 | chomp( $line ); |
174 | next if $line =~ /^\s*#/; |
175 | |
176 | $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod; |
177 | |
178 | if ( $in_pod || $line =~ /^=cut/ ) { |
179 | |
180 | if ( $line =~ /^=head\d\s+(.+)\s*$/ ) { |
181 | push( @pod, $1 ); |
182 | if ( $self->{collect_pod} && length( $pod_data ) ) { |
183 | $pod{$pod_sect} = $pod_data; |
184 | $pod_data = ''; |
185 | } |
186 | $pod_sect = $1; |
187 | |
188 | |
189 | } elsif ( $self->{collect_pod} ) { |
190 | $pod_data .= "$line\n"; |
191 | |
192 | } |
193 | |
194 | } else { |
195 | |
196 | $pod_sect = ''; |
197 | $pod_data = ''; |
198 | |
199 | # parse $line to see if it's a $VERSION declaration |
200 | my( $vers_sig, $vers_fullname, $vers_pkg ) = |
201 | $self->_parse_version_expression( $line ); |
202 | |
203 | if ( $line =~ $PKG_REGEXP ) { |
204 | $pkg = $1; |
205 | push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs ); |
206 | $vers{$pkg} = undef unless exists( $vers{$pkg} ); |
207 | $need_vers = 1; |
208 | |
209 | # VERSION defined with full package spec, i.e. $Module::VERSION |
210 | } elsif ( $vers_fullname && $vers_pkg ) { |
211 | push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs ); |
212 | $need_vers = 0 if $vers_pkg eq $pkg; |
213 | |
214 | my $v = |
215 | $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); |
216 | unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) { |
217 | $vers{$vers_pkg} = $v; |
218 | } else { |
219 | warn <<"EOM"; |
220 | Package '$vers_pkg' already declared with version '$vers{$vers_pkg}' |
221 | ignoring new version '$v'. |
222 | EOM |
223 | } |
224 | |
225 | # first non-comment line in undeclared package main is VERSION |
226 | } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) { |
227 | $need_vers = 0; |
228 | my $v = |
229 | $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); |
230 | $vers{$pkg} = $v; |
231 | push( @pkgs, 'main' ); |
232 | |
233 | # first non-comement line in undeclared packge defines package main |
234 | } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) { |
235 | $need_vers = 1; |
236 | $vers{main} = ''; |
237 | push( @pkgs, 'main' ); |
238 | |
239 | # only keep if this is the first $VERSION seen |
240 | } elsif ( $vers_fullname && $need_vers ) { |
241 | $need_vers = 0; |
242 | my $v = |
243 | $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); |
244 | |
245 | |
246 | unless ( defined $vers{$pkg} && length $vers{$pkg} ) { |
247 | $vers{$pkg} = $v; |
248 | } else { |
249 | warn <<"EOM"; |
250 | Package '$pkg' already declared with version '$vers{$pkg}' |
251 | ignoring new version '$v'. |
252 | EOM |
253 | } |
254 | |
255 | } |
256 | |
257 | } |
258 | |
259 | } |
260 | |
261 | if ( $self->{collect_pod} && length($pod_data) ) { |
262 | $pod{$pod_sect} = $pod_data; |
263 | } |
264 | |
265 | $self->{versions} = \%vers; |
266 | $self->{packages} = \@pkgs; |
267 | $self->{pod} = \%pod; |
268 | $self->{pod_headings} = \@pod; |
269 | } |
270 | |
271 | sub _evaluate_version_line { |
272 | my $self = shift; |
273 | my( $sigil, $var, $line ) = @_; |
274 | |
275 | # Some of this code came from the ExtUtils:: hierarchy. |
276 | |
277 | my $eval = qq{q# Hide from _packages_inside() |
278 | #; package Module::Build::ModuleInfo::_version; |
279 | no strict; |
280 | |
281 | local $sigil$var; |
282 | \$$var=undef; do { |
283 | $line |
284 | }; \$$var |
285 | }; |
286 | local $^W; |
287 | |
288 | # version.pm will change the ->VERSION method, so we mitigate the |
289 | # potential effects here. Unfortunately local(*UNIVERSAL::VERSION) |
290 | # will crash perl < 5.8.1. We also use * Foo::VERSION instead of |
291 | # *Foo::VERSION so that old versions of CPAN.pm, etc. with a |
292 | # too-permissive regex don't think we're actually declaring a |
293 | # version. |
294 | |
295 | my $old_version = \&UNIVERSAL::VERSION; |
296 | eval {require version}; |
297 | my $result = eval $eval; |
298 | * UNIVERSAL::VERSION = $old_version; |
299 | warn "Error evaling version line '$eval' in $self->{filename}: $@\n" if $@; |
300 | |
301 | # Unbless it if it's a version.pm object |
302 | $result = $result->numify if UNIVERSAL::isa($result, 'version'); |
303 | |
304 | return $result; |
305 | } |
306 | |
307 | |
308 | ############################################################ |
309 | |
310 | # accessors |
311 | sub name { $_[0]->{module} } |
312 | |
313 | sub filename { $_[0]->{filename} } |
314 | sub packages_inside { @{$_[0]->{packages}} } |
315 | sub pod_inside { @{$_[0]->{pod_headings}} } |
316 | sub contains_pod { $#{$_[0]->{pod_headings}} } |
317 | |
318 | sub version { |
319 | my $self = shift; |
320 | my $mod = shift || $self->{module}; |
321 | my $vers; |
322 | if ( defined( $mod ) && length( $mod ) && |
323 | exists( $self->{versions}{$mod} ) ) { |
324 | return $self->{versions}{$mod}; |
325 | } else { |
326 | return undef; |
327 | } |
328 | } |
329 | |
330 | sub pod { |
331 | my $self = shift; |
332 | my $sect = shift; |
333 | if ( defined( $sect ) && length( $sect ) && |
334 | exists( $self->{pod}{$sect} ) ) { |
335 | return $self->{pod}{$sect}; |
336 | } else { |
337 | return undef; |
338 | } |
339 | } |
340 | |
341 | 1; |
342 | |
343 | __END__ |
344 | |
345 | =head1 NAME |
346 | |
347 | ModuleInfo - Gather package and POD information from a perl module files |
348 | |
349 | |
350 | =head1 DESCRIPTION |
351 | |
352 | =over 4 |
353 | |
354 | =item new_from_file($filename, collect_pod => 1) |
355 | |
356 | Construct a ModuleInfo object given the path to a file. Takes an optional |
357 | arguement C<collect_pod> which is a boolean that determines whether |
358 | POD data is collected and stored for reference. POD data is not |
359 | collected by default. POD headings are always collected. |
360 | |
361 | =item new_from_module($module, collect_pod => 1, inc => \@dirs) |
362 | |
363 | Construct a ModuleInfo object given a module or package name. In addition |
364 | to accepting the C<collect_pod> argument as described above, this |
365 | method accepts a C<inc> arguemnt which is a reference to an array of |
366 | of directories to search for the module. If none are given, the |
367 | default is @INC. |
368 | |
369 | =item name() |
370 | |
371 | Returns the name of the package represented by this module. If there |
372 | are more than one packages, it makes a best guess based on the |
373 | filename. If it's a script (i.e. not a *.pm) the package name is |
374 | 'main'. |
375 | |
376 | =item version($package) |
377 | |
378 | Returns the version as defined by the $VERSION variable for the |
379 | package as returned by the C<name> method if no arguments are |
380 | given. If given the name of a package it will attempt to return the |
381 | version of that package if it is specified in the file. |
382 | |
383 | =item filename() |
384 | |
385 | Returns the absolute path to the file. |
386 | |
387 | =item packages_inside() |
388 | |
389 | Returns a list of packages. |
390 | |
391 | =item pod_inside() |
392 | |
393 | Returns a list of POD sections. |
394 | |
395 | =item contains_pod() |
396 | |
397 | Returns true if there is any POD in the file. |
398 | |
399 | =item pod($section) |
400 | |
401 | Returns the POD data in the given section. |
402 | |
403 | =item find_module_by_name($module, \@dirs) |
404 | |
405 | Returns the path to a module given the module or package name. A list |
406 | of directories can be passed in as an optional paramater, otherwise |
407 | @INC is searched. |
408 | |
409 | Can be called as either an object or a class method. |
410 | |
411 | =item find_module_dir_by_name($module, \@dirs) |
412 | |
413 | Returns the entry in C<@dirs> (or C<@INC> by default) that contains |
414 | the module C<$module>. A list of directories can be passed in as an |
415 | optional paramater, otherwise @INC is searched. |
416 | |
417 | Can be called as either an object or a class method. |
418 | |
419 | =back |
420 | |
421 | |
422 | =head1 AUTHOR |
423 | |
424 | Ken Williams <ken@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org> |
425 | |
426 | |
427 | =head1 COPYRIGHT |
428 | |
429 | Copyright (c) 2001-2005 Ken Williams. All rights reserved. |
430 | |
431 | This library is free software; you can redistribute it and/or |
432 | modify it under the same terms as Perl itself. |
433 | |
434 | |
435 | =head1 SEE ALSO |
436 | |
437 | perl(1), Module::Build(3) |
438 | |
439 | =cut |
440 | |