This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate version.pm-0.77 into bleadperl
[perl5.git] / lib / Module / Build / ModuleInfo.pm
CommitLineData
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
3package 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
9use strict;
7a827510 10use vars qw($VERSION);
94410036 11$VERSION = '0.33_02';
7a827510 12$VERSION = eval $VERSION;
bb4e9162
YST
13
14use File::Spec;
15use IO::File;
b3dfda33 16use Module::Build::Version;
bb4e9162
YST
17
18
738349a8 19my $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 28my $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 39my $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
50sub 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
58sub 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
69sub _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
121sub _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
138sub find_module_by_name {
139 my $found = shift()->_do_find_module(@_) or return;
140 return $found->[0];
141}
142
143# class method
144sub 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
152sub _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
168sub _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
178sub _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/;
242Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
738349a8 243ignoring subsequent declaration on line $line_num.
bb4e9162
YST
244EOM
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";
272Package '$pkg' already declared with version '$vers{$pkg}'
738349a8 273ignoring new version '$v' on line $line_num.
bb4e9162
YST
274EOM
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{
294my $pn = 0;
bb4e9162
YST
295sub _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
340sub name { $_[0]->{module} }
341
342sub filename { $_[0]->{filename} }
343sub packages_inside { @{$_[0]->{packages}} }
344sub pod_inside { @{$_[0]->{pod_headings}} }
345sub contains_pod { $#{$_[0]->{pod_headings}} }
346
347sub 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
359sub 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
3701;
371
372__END__
373
374=head1 NAME
375
376ModuleInfo - 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
385Construct a ModuleInfo object given the path to a file. Takes an optional
386arguement C<collect_pod> which is a boolean that determines whether
387POD data is collected and stored for reference. POD data is not
388collected by default. POD headings are always collected.
389
390=item new_from_module($module, collect_pod => 1, inc => \@dirs)
391
392Construct a ModuleInfo object given a module or package name. In addition
393to accepting the C<collect_pod> argument as described above, this
394method accepts a C<inc> arguemnt which is a reference to an array of
395of directories to search for the module. If none are given, the
396default is @INC.
397
398=item name()
399
400Returns the name of the package represented by this module. If there
401are more than one packages, it makes a best guess based on the
402filename. If it's a script (i.e. not a *.pm) the package name is
403'main'.
404
405=item version($package)
406
407Returns the version as defined by the $VERSION variable for the
408package as returned by the C<name> method if no arguments are
409given. If given the name of a package it will attempt to return the
410version of that package if it is specified in the file.
411
412=item filename()
413
414Returns the absolute path to the file.
415
416=item packages_inside()
417
418Returns a list of packages.
419
420=item pod_inside()
421
422Returns a list of POD sections.
423
424=item contains_pod()
425
426Returns true if there is any POD in the file.
427
428=item pod($section)
429
430Returns the POD data in the given section.
431
432=item find_module_by_name($module, \@dirs)
433
434Returns the path to a module given the module or package name. A list
435of directories can be passed in as an optional paramater, otherwise
436@INC is searched.
437
438Can be called as either an object or a class method.
439
440=item find_module_dir_by_name($module, \@dirs)
441
442Returns the entry in C<@dirs> (or C<@INC> by default) that contains
443the module C<$module>. A list of directories can be passed in as an
444optional paramater, otherwise @INC is searched.
445
446Can be called as either an object or a class method.
447
448=back
449
450
451=head1 AUTHOR
452
77e96e88 453Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
bb4e9162
YST
454
455
456=head1 COPYRIGHT
457
77e96e88 458Copyright (c) 2001-2006 Ken Williams. All rights reserved.
bb4e9162
YST
459
460This library is free software; you can redistribute it and/or
461modify it under the same terms as Perl itself.
462
463
464=head1 SEE ALSO
465
dc8021d3 466perl(1), L<Module::Build>(3)
bb4e9162
YST
467
468=cut
469