This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[patch@31780] fixes for cpanplus on VMS
[perl5.git] / lib / Module / Build / ModuleInfo.pm
CommitLineData
bb4e9162
YST
1package 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
7use strict;
8
9use File::Spec;
10use IO::File;
b3dfda33 11use Module::Build::Version;
bb4e9162
YST
12
13
14my $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
23my $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
34my $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
45sub 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
52sub 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
62sub _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
112sub _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
129sub find_module_by_name {
130 my $found = shift()->_do_find_module(@_) or return;
131 return $found->[0];
132}
133
134# class method
135sub 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
143sub _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
159sub _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
169sub _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/;
232Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
233ignoring subsequent declaration.
bb4e9162
YST
234EOM
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";
262Package '$pkg' already declared with version '$vers{$pkg}'
263ignoring new version '$v'.
264EOM
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
283sub _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
323sub name { $_[0]->{module} }
324
325sub filename { $_[0]->{filename} }
326sub packages_inside { @{$_[0]->{packages}} }
327sub pod_inside { @{$_[0]->{pod_headings}} }
328sub contains_pod { $#{$_[0]->{pod_headings}} }
329
330sub 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
342sub 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
3531;
354
355__END__
356
357=head1 NAME
358
359ModuleInfo - 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
368Construct a ModuleInfo object given the path to a file. Takes an optional
369arguement C<collect_pod> which is a boolean that determines whether
370POD data is collected and stored for reference. POD data is not
371collected by default. POD headings are always collected.
372
373=item new_from_module($module, collect_pod => 1, inc => \@dirs)
374
375Construct a ModuleInfo object given a module or package name. In addition
376to accepting the C<collect_pod> argument as described above, this
377method accepts a C<inc> arguemnt which is a reference to an array of
378of directories to search for the module. If none are given, the
379default is @INC.
380
381=item name()
382
383Returns the name of the package represented by this module. If there
384are more than one packages, it makes a best guess based on the
385filename. If it's a script (i.e. not a *.pm) the package name is
386'main'.
387
388=item version($package)
389
390Returns the version as defined by the $VERSION variable for the
391package as returned by the C<name> method if no arguments are
392given. If given the name of a package it will attempt to return the
393version of that package if it is specified in the file.
394
395=item filename()
396
397Returns the absolute path to the file.
398
399=item packages_inside()
400
401Returns a list of packages.
402
403=item pod_inside()
404
405Returns a list of POD sections.
406
407=item contains_pod()
408
409Returns true if there is any POD in the file.
410
411=item pod($section)
412
413Returns the POD data in the given section.
414
415=item find_module_by_name($module, \@dirs)
416
417Returns the path to a module given the module or package name. A list
418of directories can be passed in as an optional paramater, otherwise
419@INC is searched.
420
421Can be called as either an object or a class method.
422
423=item find_module_dir_by_name($module, \@dirs)
424
425Returns the entry in C<@dirs> (or C<@INC> by default) that contains
426the module C<$module>. A list of directories can be passed in as an
427optional paramater, otherwise @INC is searched.
428
429Can be called as either an object or a class method.
430
431=back
432
433
434=head1 AUTHOR
435
77e96e88 436Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
bb4e9162
YST
437
438
439=head1 COPYRIGHT
440
77e96e88 441Copyright (c) 2001-2006 Ken Williams. All rights reserved.
bb4e9162
YST
442
443This library is free software; you can redistribute it and/or
444modify it under the same terms as Perl itself.
445
446
447=head1 SEE ALSO
448
dc8021d3 449perl(1), L<Module::Build>(3)
bb4e9162
YST
450
451=cut
452