Update Module::Build to 0.35
[perl.git] / lib / Module / Build / ModuleInfo.pm
1 # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
2 # vim:ts=8:sw=2:et:sta:sts=2
3 package 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
9 use strict;
10 use vars qw($VERSION);
11 $VERSION = '0.35';
12 $VERSION = eval $VERSION;
13
14 use File::Spec;
15 use IO::File;
16 use Module::Build::Version;
17
18
19 my $PKG_REGEXP  = qr{   # match a package declaration
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
26 }x;
27
28 my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
29   ([\$*])         # sigil - $ or *
30   (
31     (             # optional leading package name
32       (?:::|\')?  # possibly starting like just :: (�  la $::VERSION)
33       (?:\w+(?:::|\'))*  # Foo::Bar:: ...
34     )?
35     VERSION
36   )\b
37 }x;
38
39 my $VERS_REGEXP = qr{ # match a VERSION definition
40   (?:
41     \(\s*$VARNAME_REGEXP\s*\) # with parens
42   |
43     $VARNAME_REGEXP           # without parens
44   )
45   \s*
46   =[^=~]  # = but not ==, nor =~
47 }x;
48
49
50 sub new_from_file {
51   my $class    = shift;
52   my $filename = File::Spec->rel2abs( shift );
53
54   return undef unless defined( $filename ) && -f $filename;
55   return $class->_init(undef, $filename, @_);
56 }
57
58 sub new_from_module {
59   my $class   = shift;
60   my $module  = shift;
61   my %props   = @_;
62
63   $props{inc} ||= \@INC;
64   my $filename = $class->find_module_by_name( $module, $props{inc} );
65   return undef unless defined( $filename ) && -f $filename;
66   return $class->_init($module, $filename, %props);
67 }
68
69 sub _init {
70   my $class    = shift;
71   my $module   = shift;
72   my $filename = shift;
73   my %props = @_;
74
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 = (
81     module       => $module,
82     filename     => $filename,
83     version      => undef,
84     packages     => [],
85     versions     => {},
86     pod          => {},
87     pod_headings => [],
88     collect_pod  => 0,
89
90     %valid_props,
91   );
92
93   my $self = bless(\%data, $class);
94
95   $self->_parse_file();
96
97   unless($self->{module} and length($self->{module})) {
98     my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
99     if($f =~ /\.pm$/) {
100       $f =~ s/\..+$//;
101       my @candidates = grep /$f$/, @{$self->{packages}};
102       $self->{module} = shift(@candidates); # punt
103     }
104     else {
105       if(grep /main/, @{$self->{packages}}) {
106         $self->{module} = 'main';
107       }
108       else {
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
121 sub _do_find_module {
122   my $class   = shift;
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
138 sub find_module_by_name {
139   my $found = shift()->_do_find_module(@_) or return;
140   return $found->[0];
141 }
142
143 # class method
144 sub 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
152 sub _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
168 sub _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
175   $self->_parse_fh($fh);
176 }
177
178 sub _parse_fh {
179   my ($self, $fh) = @_;
180
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> )) {
188     my $line_num = $.;
189
190     chomp( $line );
191     next if $line =~ /^\s*#/;
192
193     $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
194
195     # Would be nice if we could also check $in_string or something too
196     last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
197
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
234         unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
235           $vers{$vers_pkg} = 
236             $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
237         } else {
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/;
242 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
243 ignoring subsequent declaration on line $line_num.
244 EOM
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-comment line in undeclared package 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";
272 Package '$pkg' already declared with version '$vers{$pkg}'
273 ignoring new version '$v' on line $line_num.
274 EOM
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
293 {
294 my $pn = 0;
295 sub _evaluate_version_line {
296   my $self = shift;
297   my( $sigil, $var, $line ) = @_;
298
299   # Some of this code came from the ExtUtils:: hierarchy.
300
301   # We compile into $vsub because 'use version' would cause
302   # compiletime/runtime issues with local()
303   my $vsub;
304   $pn++; # everybody gets their own package
305   my $eval = qq{BEGIN { q#  Hide from _packages_inside()
306     #; package Module::Build::ModuleInfo::_version::p$pn;
307     use Module::Build::Version;
308     no strict;
309
310     local $sigil$var;
311     \$$var=undef;
312       \$vsub = sub {
313         $line;
314         \$$var
315       };
316   }};
317
318   local $^W;
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}";
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 $@;
328
329   # Bless it into our own version class
330   $result = Module::Build::Version->new($result);
331
332   return $result;
333 }
334 }
335
336
337 ############################################################
338
339 # accessors
340 sub name            { $_[0]->{module}           }
341
342 sub filename        { $_[0]->{filename}         }
343 sub packages_inside { @{$_[0]->{packages}}      }
344 sub pod_inside      { @{$_[0]->{pod_headings}}  }
345 sub contains_pod    { $#{$_[0]->{pod_headings}} }
346
347 sub 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
359 sub 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
370 1;
371
372 __END__
373
374 =for :stopwords ModuleInfo
375
376 =head1 NAME
377
378 ModuleInfo - Gather package and POD information from a perl module file
379
380
381 =head1 DESCRIPTION
382
383 =over 4
384
385 =item new_from_file($filename, collect_pod => 1)
386
387 Construct a C<ModuleInfo> object given the path to a file. Takes an optional
388 argument C<collect_pod> which is a boolean that determines whether
389 POD data is collected and stored for reference. POD data is not
390 collected by default. POD headings are always collected.
391
392 =item new_from_module($module, collect_pod => 1, inc => \@dirs)
393
394 Construct a C<ModuleInfo> object given a module or package name. In addition
395 to accepting the C<collect_pod> argument as described above, this
396 method accepts a C<inc> argument which is a reference to an array of
397 of directories to search for the module. If none are given, the
398 default is @INC.
399
400 =item name()
401
402 Returns the name of the package represented by this module. If there
403 are more than one packages, it makes a best guess based on the
404 filename. If it's a script (i.e. not a *.pm) the package name is
405 'main'.
406
407 =item version($package)
408
409 Returns the version as defined by the $VERSION variable for the
410 package as returned by the C<name> method if no arguments are
411 given. If given the name of a package it will attempt to return the
412 version of that package if it is specified in the file.
413
414 =item filename()
415
416 Returns the absolute path to the file.
417
418 =item packages_inside()
419
420 Returns a list of packages.
421
422 =item pod_inside()
423
424 Returns a list of POD sections.
425
426 =item contains_pod()
427
428 Returns true if there is any POD in the file.
429
430 =item pod($section)
431
432 Returns the POD data in the given section.
433
434 =item find_module_by_name($module, \@dirs)
435
436 Returns the path to a module given the module or package name. A list
437 of directories can be passed in as an optional parameter, otherwise
438 @INC is searched.
439
440 Can be called as either an object or a class method.
441
442 =item find_module_dir_by_name($module, \@dirs)
443
444 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
445 the module C<$module>. A list of directories can be passed in as an
446 optional parameter, otherwise @INC is searched.
447
448 Can be called as either an object or a class method.
449
450 =back
451
452
453 =head1 AUTHOR
454
455 Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
456
457
458 =head1 COPYRIGHT
459
460 Copyright (c) 2001-2006 Ken Williams.  All rights reserved.
461
462 This library is free software; you can redistribute it and/or
463 modify it under the same terms as Perl itself.
464
465
466 =head1 SEE ALSO
467
468 perl(1), L<Module::Build>(3)
469
470 =cut
471