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