472 lines
12 KiB
Perl
472 lines
12 KiB
Perl
# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
|
|
# vim:ts=8:sw=2:et:sta:sts=2
|
|
package Module::Build::ModuleInfo;
|
|
|
|
# This module provides routines to gather information about
|
|
# perl modules (assuming this may be expanded in the distant
|
|
# parrot future to look at other types of modules).
|
|
|
|
use strict;
|
|
use vars qw($VERSION);
|
|
$VERSION = '0.34';
|
|
$VERSION = eval $VERSION;
|
|
|
|
use File::Spec;
|
|
use IO::File;
|
|
use Module::Build::Version;
|
|
|
|
|
|
my $PKG_REGEXP = qr{ # match a package declaration
|
|
^[\s\{;]* # intro chars on a line
|
|
package # the word 'package'
|
|
\s+ # whitespace
|
|
([\w:]+) # a package name
|
|
\s* # optional whitespace
|
|
; # semicolon line terminator
|
|
}x;
|
|
|
|
my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
|
|
([\$*]) # sigil - $ or *
|
|
(
|
|
( # optional leading package name
|
|
(?:::|\')? # possibly starting like just :: (Ì la $::VERSION)
|
|
(?:\w+(?:::|\'))* # Foo::Bar:: ...
|
|
)?
|
|
VERSION
|
|
)\b
|
|
}x;
|
|
|
|
my $VERS_REGEXP = qr{ # match a VERSION definition
|
|
(?:
|
|
\(\s*$VARNAME_REGEXP\s*\) # with parens
|
|
|
|
|
$VARNAME_REGEXP # without parens
|
|
)
|
|
\s*
|
|
=[^=~] # = but not ==, nor =~
|
|
}x;
|
|
|
|
|
|
sub new_from_file {
|
|
my $class = shift;
|
|
my $filename = File::Spec->rel2abs( shift );
|
|
|
|
return undef unless defined( $filename ) && -f $filename;
|
|
return $class->_init(undef, $filename, @_);
|
|
}
|
|
|
|
sub new_from_module {
|
|
my $class = shift;
|
|
my $module = shift;
|
|
my %props = @_;
|
|
|
|
$props{inc} ||= \@INC;
|
|
my $filename = $class->find_module_by_name( $module, $props{inc} );
|
|
return undef unless defined( $filename ) && -f $filename;
|
|
return $class->_init($module, $filename, %props);
|
|
}
|
|
|
|
sub _init {
|
|
my $class = shift;
|
|
my $module = shift;
|
|
my $filename = shift;
|
|
my %props = @_;
|
|
|
|
my( %valid_props, @valid_props );
|
|
@valid_props = qw( collect_pod inc );
|
|
@valid_props{@valid_props} = delete( @props{@valid_props} );
|
|
warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
|
|
|
|
my %data = (
|
|
module => $module,
|
|
filename => $filename,
|
|
version => undef,
|
|
packages => [],
|
|
versions => {},
|
|
pod => {},
|
|
pod_headings => [],
|
|
collect_pod => 0,
|
|
|
|
%valid_props,
|
|
);
|
|
|
|
my $self = bless(\%data, $class);
|
|
|
|
$self->_parse_file();
|
|
|
|
unless($self->{module} and length($self->{module})) {
|
|
my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
|
|
if($f =~ /\.pm$/) {
|
|
$f =~ s/\..+$//;
|
|
my @candidates = grep /$f$/, @{$self->{packages}};
|
|
$self->{module} = shift(@candidates); # punt
|
|
}
|
|
else {
|
|
if(grep /main/, @{$self->{packages}}) {
|
|
$self->{module} = 'main';
|
|
}
|
|
else {
|
|
$self->{module} = $self->{packages}[0] || '';
|
|
}
|
|
}
|
|
}
|
|
|
|
$self->{version} = $self->{versions}{$self->{module}}
|
|
if defined( $self->{module} );
|
|
|
|
return $self;
|
|
}
|
|
|
|
# class method
|
|
sub _do_find_module {
|
|
my $class = shift;
|
|
my $module = shift || die 'find_module_by_name() requires a package name';
|
|
my $dirs = shift || \@INC;
|
|
|
|
my $file = File::Spec->catfile(split( /::/, $module));
|
|
foreach my $dir ( @$dirs ) {
|
|
my $testfile = File::Spec->catfile($dir, $file);
|
|
return [ File::Spec->rel2abs( $testfile ), $dir ]
|
|
if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
|
|
return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
|
|
if -e "$testfile.pm";
|
|
}
|
|
return;
|
|
}
|
|
|
|
# class method
|
|
sub find_module_by_name {
|
|
my $found = shift()->_do_find_module(@_) or return;
|
|
return $found->[0];
|
|
}
|
|
|
|
# class method
|
|
sub find_module_dir_by_name {
|
|
my $found = shift()->_do_find_module(@_) or return;
|
|
return $found->[1];
|
|
}
|
|
|
|
|
|
# given a line of perl code, attempt to parse it if it looks like a
|
|
# $VERSION assignment, returning sigil, full name, & package name
|
|
sub _parse_version_expression {
|
|
my $self = shift;
|
|
my $line = shift;
|
|
|
|
my( $sig, $var, $pkg );
|
|
if ( $line =~ $VERS_REGEXP ) {
|
|
( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
|
|
if ( $pkg ) {
|
|
$pkg = ($pkg eq '::') ? 'main' : $pkg;
|
|
$pkg =~ s/::$//;
|
|
}
|
|
}
|
|
|
|
return ( $sig, $var, $pkg );
|
|
}
|
|
|
|
sub _parse_file {
|
|
my $self = shift;
|
|
|
|
my $filename = $self->{filename};
|
|
my $fh = IO::File->new( $filename )
|
|
or die( "Can't open '$filename': $!" );
|
|
|
|
$self->_parse_fh($fh);
|
|
}
|
|
|
|
sub _parse_fh {
|
|
my ($self, $fh) = @_;
|
|
|
|
my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
|
|
my( @pkgs, %vers, %pod, @pod );
|
|
my $pkg = 'main';
|
|
my $pod_sect = '';
|
|
my $pod_data = '';
|
|
|
|
while (defined( my $line = <$fh> )) {
|
|
my $line_num = $.;
|
|
|
|
chomp( $line );
|
|
next if $line =~ /^\s*#/;
|
|
|
|
$in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
|
|
|
|
# Would be nice if we could also check $in_string or something too
|
|
last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
|
|
|
|
if ( $in_pod || $line =~ /^=cut/ ) {
|
|
|
|
if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
|
|
push( @pod, $1 );
|
|
if ( $self->{collect_pod} && length( $pod_data ) ) {
|
|
$pod{$pod_sect} = $pod_data;
|
|
$pod_data = '';
|
|
}
|
|
$pod_sect = $1;
|
|
|
|
|
|
} elsif ( $self->{collect_pod} ) {
|
|
$pod_data .= "$line\n";
|
|
|
|
}
|
|
|
|
} else {
|
|
|
|
$pod_sect = '';
|
|
$pod_data = '';
|
|
|
|
# parse $line to see if it's a $VERSION declaration
|
|
my( $vers_sig, $vers_fullname, $vers_pkg ) =
|
|
$self->_parse_version_expression( $line );
|
|
|
|
if ( $line =~ $PKG_REGEXP ) {
|
|
$pkg = $1;
|
|
push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
|
|
$vers{$pkg} = undef unless exists( $vers{$pkg} );
|
|
$need_vers = 1;
|
|
|
|
# VERSION defined with full package spec, i.e. $Module::VERSION
|
|
} elsif ( $vers_fullname && $vers_pkg ) {
|
|
push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
|
|
$need_vers = 0 if $vers_pkg eq $pkg;
|
|
|
|
unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
|
|
$vers{$vers_pkg} =
|
|
$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
|
|
} else {
|
|
# Warn unless the user is using the "$VERSION = eval
|
|
# $VERSION" idiom (though there are probably other idioms
|
|
# that we should watch out for...)
|
|
warn <<"EOM" unless $line =~ /=\s*eval/;
|
|
Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
|
|
ignoring subsequent declaration on line $line_num.
|
|
EOM
|
|
}
|
|
|
|
# first non-comment line in undeclared package main is VERSION
|
|
} elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
|
|
$need_vers = 0;
|
|
my $v =
|
|
$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
|
|
$vers{$pkg} = $v;
|
|
push( @pkgs, 'main' );
|
|
|
|
# first non-comment line in undeclared package defines package main
|
|
} elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
|
|
$need_vers = 1;
|
|
$vers{main} = '';
|
|
push( @pkgs, 'main' );
|
|
|
|
# only keep if this is the first $VERSION seen
|
|
} elsif ( $vers_fullname && $need_vers ) {
|
|
$need_vers = 0;
|
|
my $v =
|
|
$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
|
|
|
|
|
|
unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
|
|
$vers{$pkg} = $v;
|
|
} else {
|
|
warn <<"EOM";
|
|
Package '$pkg' already declared with version '$vers{$pkg}'
|
|
ignoring new version '$v' on line $line_num.
|
|
EOM
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
if ( $self->{collect_pod} && length($pod_data) ) {
|
|
$pod{$pod_sect} = $pod_data;
|
|
}
|
|
|
|
$self->{versions} = \%vers;
|
|
$self->{packages} = \@pkgs;
|
|
$self->{pod} = \%pod;
|
|
$self->{pod_headings} = \@pod;
|
|
}
|
|
|
|
{
|
|
my $pn = 0;
|
|
sub _evaluate_version_line {
|
|
my $self = shift;
|
|
my( $sigil, $var, $line ) = @_;
|
|
|
|
# Some of this code came from the ExtUtils:: hierarchy.
|
|
|
|
# We compile into $vsub because 'use version' would cause
|
|
# compiletime/runtime issues with local()
|
|
my $vsub;
|
|
$pn++; # everybody gets their own package
|
|
my $eval = qq{BEGIN { q# Hide from _packages_inside()
|
|
#; package Module::Build::ModuleInfo::_version::p$pn;
|
|
use Module::Build::Version;
|
|
no strict;
|
|
|
|
local $sigil$var;
|
|
\$$var=undef;
|
|
\$vsub = sub {
|
|
$line;
|
|
\$$var
|
|
};
|
|
}};
|
|
|
|
local $^W;
|
|
# Try to get the $VERSION
|
|
eval $eval;
|
|
warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
|
|
if $@;
|
|
(ref($vsub) eq 'CODE') or
|
|
die "failed to build version sub for $self->{filename}";
|
|
my $result = eval { $vsub->() };
|
|
|
|
die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" if $@;
|
|
|
|
# Bless it into our own version class
|
|
$result = Module::Build::Version->new($result);
|
|
|
|
return $result;
|
|
}
|
|
}
|
|
|
|
|
|
############################################################
|
|
|
|
# accessors
|
|
sub name { $_[0]->{module} }
|
|
|
|
sub filename { $_[0]->{filename} }
|
|
sub packages_inside { @{$_[0]->{packages}} }
|
|
sub pod_inside { @{$_[0]->{pod_headings}} }
|
|
sub contains_pod { $#{$_[0]->{pod_headings}} }
|
|
|
|
sub version {
|
|
my $self = shift;
|
|
my $mod = shift || $self->{module};
|
|
my $vers;
|
|
if ( defined( $mod ) && length( $mod ) &&
|
|
exists( $self->{versions}{$mod} ) ) {
|
|
return $self->{versions}{$mod};
|
|
} else {
|
|
return undef;
|
|
}
|
|
}
|
|
|
|
sub pod {
|
|
my $self = shift;
|
|
my $sect = shift;
|
|
if ( defined( $sect ) && length( $sect ) &&
|
|
exists( $self->{pod}{$sect} ) ) {
|
|
return $self->{pod}{$sect};
|
|
} else {
|
|
return undef;
|
|
}
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=for :stopwords ModuleInfo
|
|
|
|
=head1 NAME
|
|
|
|
ModuleInfo - Gather package and POD information from a perl module file
|
|
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
=over 4
|
|
|
|
=item new_from_file($filename, collect_pod => 1)
|
|
|
|
Construct a C<ModuleInfo> object given the path to a file. Takes an optional
|
|
argument C<collect_pod> which is a boolean that determines whether
|
|
POD data is collected and stored for reference. POD data is not
|
|
collected by default. POD headings are always collected.
|
|
|
|
=item new_from_module($module, collect_pod => 1, inc => \@dirs)
|
|
|
|
Construct a C<ModuleInfo> object given a module or package name. In addition
|
|
to accepting the C<collect_pod> argument as described above, this
|
|
method accepts a C<inc> argument which is a reference to an array of
|
|
of directories to search for the module. If none are given, the
|
|
default is @INC.
|
|
|
|
=item name()
|
|
|
|
Returns the name of the package represented by this module. If there
|
|
are more than one packages, it makes a best guess based on the
|
|
filename. If it's a script (i.e. not a *.pm) the package name is
|
|
'main'.
|
|
|
|
=item version($package)
|
|
|
|
Returns the version as defined by the $VERSION variable for the
|
|
package as returned by the C<name> method if no arguments are
|
|
given. If given the name of a package it will attempt to return the
|
|
version of that package if it is specified in the file.
|
|
|
|
=item filename()
|
|
|
|
Returns the absolute path to the file.
|
|
|
|
=item packages_inside()
|
|
|
|
Returns a list of packages.
|
|
|
|
=item pod_inside()
|
|
|
|
Returns a list of POD sections.
|
|
|
|
=item contains_pod()
|
|
|
|
Returns true if there is any POD in the file.
|
|
|
|
=item pod($section)
|
|
|
|
Returns the POD data in the given section.
|
|
|
|
=item find_module_by_name($module, \@dirs)
|
|
|
|
Returns the path to a module given the module or package name. A list
|
|
of directories can be passed in as an optional parameter, otherwise
|
|
@INC is searched.
|
|
|
|
Can be called as either an object or a class method.
|
|
|
|
=item find_module_dir_by_name($module, \@dirs)
|
|
|
|
Returns the entry in C<@dirs> (or C<@INC> by default) that contains
|
|
the module C<$module>. A list of directories can be passed in as an
|
|
optional parameter, otherwise @INC is searched.
|
|
|
|
Can be called as either an object or a class method.
|
|
|
|
=back
|
|
|
|
|
|
=head1 AUTHOR
|
|
|
|
Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
|
|
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2001-2006 Ken Williams. All rights reserved.
|
|
|
|
This library is free software; you can redistribute it and/or
|
|
modify it under the same terms as Perl itself.
|
|
|
|
|
|
=head1 SEE ALSO
|
|
|
|
perl(1), L<Module::Build>(3)
|
|
|
|
=cut
|
|
|