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