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