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