Commit | Line | Data |
---|---|---|
738349a8 SH |
1 | # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- |
2 | # vim:ts=8:sw=2:et:sta:sts=2 | |
bb4e9162 YST |
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); |
66e531b6 | 11 | $VERSION = '0.31_04'; |
7a827510 | 12 | $VERSION = eval $VERSION; |
bb4e9162 YST |
13 | |
14 | use File::Spec; | |
15 | use IO::File; | |
b3dfda33 | 16 | use Module::Build::Version; |
bb4e9162 YST |
17 | |
18 | ||
738349a8 | 19 | my $PKG_REGEXP = qr{ # match a package declaration |
bb4e9162 YST |
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 YST |
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 YST |
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 YST |
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 YST |
56 | } |
57 | ||
58 | sub new_from_module { | |
738349a8 | 59 | my $class = shift; |
bb4e9162 YST |
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 YST |
67 | } |
68 | ||
69 | sub _init { | |
738349a8 | 70 | my $class = shift; |
bb4e9162 YST |
71 | my $module = shift; |
72 | my $filename = shift; | |
bb4e9162 | 73 | my %props = @_; |
738349a8 | 74 | |
bb4e9162 YST |
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 SH |
81 | module => $module, |
82 | filename => $filename, | |
83 | version => undef, | |
84 | packages => [], | |
85 | versions => {}, | |
bb4e9162 YST |
86 | pod => {}, |
87 | pod_headings => [], | |
88 | collect_pod => 0, | |
89 | ||
90 | %valid_props, | |
91 | ); | |
92 | ||
738349a8 | 93 | my $self = bless(\%data, $class); |
bb4e9162 YST |
94 | |
95 | $self->_parse_file(); | |
96 | ||
738349a8 SH |
97 | unless($self->{module} and length($self->{module})) { |
98 | my ($v, $d, $f) = File::Spec->splitpath($self->{filename}); | |
99 | if($f =~ /\.pm$/) { | |
bb4e9162 YST |
100 | $f =~ s/\..+$//; |
101 | my @candidates = grep /$f$/, @{$self->{packages}}; | |
738349a8 SH |
102 | $self->{module} = shift(@candidates); # punt |
103 | } | |
104 | else { | |
105 | if(grep /main/, @{$self->{packages}}) { | |
106 | $self->{module} = 'main'; | |
107 | } | |
108 | else { | |
bb4e9162 YST |
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 YST |
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 RGS |
175 | $self->_parse_fh($fh); |
176 | } | |
177 | ||
178 | sub _parse_fh { | |
179 | my ($self, $fh) = @_; | |
180 | ||
bb4e9162 YST |
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 YST |
189 | |
190 | chomp( $line ); | |
191 | next if $line =~ /^\s*#/; | |
192 | ||
193 | $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod; | |
194 | ||
0ec9ad96 SP |
195 | # Would be nice if we could also check $in_string or something too |
196 | last if !$in_pod && $line =~ /^__(?:DATA|END)__$/; | |
197 | ||
bb4e9162 YST |
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 RGS |
235 | $vers{$vers_pkg} = |
236 | $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); | |
bb4e9162 | 237 | } else { |
77e96e88 RGS |
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 YST |
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 YST |
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 SH |
293 | { |
294 | my $pn = 0; | |
bb4e9162 YST |
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 SP |
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 SH |
306 | #; package Module::Build::ModuleInfo::_version::p$pn; |
307 | use Module::Build::Version; | |
7253302f SP |
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 SP |
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 SH |
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 SP |
329 | # Bless it into our own version class |
330 | $result = Module::Build::Version->new($result); | |
bb4e9162 YST |
331 | |
332 | return $result; | |
333 | } | |
738349a8 | 334 | } |
bb4e9162 YST |
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 YST |
454 | |
455 | ||
456 | =head1 COPYRIGHT | |
457 | ||
77e96e88 | 458 | Copyright (c) 2001-2006 Ken Williams. All rights reserved. |
bb4e9162 YST |
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 YST |
467 | |
468 | =cut | |
469 |