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