# parrot future to look at other types of modules).
use strict;
-use vars qw($VERSION);
-$VERSION = '1.000010';
+use warnings;
+
+our $VERSION = '1.000019';
$VERSION = eval $VERSION;
use Carp qw/croak/;
my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
+my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name
+ [a-zA-Z_] # the first word CANNOT start with a digit
+ (?:
+ [\w']? # can contain letters, digits, _, or ticks
+ \w # But, NO multi-ticks or trailing ticks
+ )*
+}x;
+
+my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name
+ \w # the 2nd+ word CAN start with digits
+ (?:
+ [\w']? # and can contain letters or ticks
+ \w # But, NO multi-ticks or trailing ticks
+ )*
+}x;
+
+my $PKG_NAME_REGEXP = qr{ # match a package name
+ (?: :: )? # a pkg name can start with aristotle
+ $PKG_FIRST_WORD_REGEXP # a package word
+ (?:
+ (?: :: )+ ### aristotle (allow one or many times)
+ $PKG_ADDL_WORD_REGEXP ### a package word
+ )* # ^ zero, one or many times
+ (?:
+ :: # allow trailing aristotle
+ )?
+}x;
+
my $PKG_REGEXP = qr{ # match a package declaration
^[\s\{;]* # intro chars on a line
package # the word 'package'
\s+ # whitespace
- ([\w:]+) # a package name
+ ($PKG_NAME_REGEXP) # a package name
\s* # optional whitespace
($V_NUM_REGEXP)? # optional version number
\s* # optional whitesapce
$VARNAME_REGEXP # without parens
)
\s*
- =[^=~] # = but not ==, nor =~
+ =[^=~>] # = but not ==, nor =~, nor =>
}x;
sub new_from_file {
}
{
-
+
my $compare_versions = sub {
my ($v1, $op, $v2) = @_;
$v1 = version->new($v1)
unless UNIVERSAL::isa($v1,'version');
-
+
my $eval_str = "\$v1 $op \$v2";
my $result = eval $eval_str;
log_info { "error comparing versions: '$eval_str' $@" } if $@;
-
+
return $result;
};
my $resolve_module_versions = sub {
my $packages = shift;
-
+
my( $file, $version );
my $err = '';
foreach my $p ( @$packages ) {
if ( defined( $p->{version} ) ) {
- if ( defined( $version ) ) {
- if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
- $err .= " $p->{file} ($p->{version})\n";
- } else {
- # same version declared multiple times, ignore
- }
- } else {
- $file = $p->{file};
- $version = $p->{version};
- }
+ if ( defined( $version ) ) {
+ if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
+ $err .= " $p->{file} ($p->{version})\n";
+ } else {
+ # same version declared multiple times, ignore
+ }
+ } else {
+ $file = $p->{file};
+ $version = $p->{version};
+ }
}
- $file ||= $p->{file} if defined( $p->{file} );
- }
-
+ $file ||= $p->{file} if defined( $p->{file} );
+ }
+
if ( $err ) {
$err = " $file ($version)\n" . $err;
}
-
+
my %result = (
file => $file,
version => $version,
err => $err
);
-
+
return \%result;
};
my $mapped_filename = File::Spec::Unix->abs2rel( $file, $dir );
my @path = split( /\//, $mapped_filename );
(my $prime_package = join( '::', @path )) =~ s/\.pm$//;
-
+
my $pm_info = $class->new_from_file( $file );
-
+
foreach my $package ( $pm_info->packages_inside ) {
next if $package eq 'main'; # main can appear numerous times, ignore
next if $package eq 'DB'; # special debugging package, ignore
next if grep /^_/, split( /::/, $package ); # private package, ignore
-
+
my $version = $pm_info->version( $package );
-
+
$prime_package = $package if lc($prime_package) eq lc($package);
if ( $package eq $prime_package ) {
if ( exists( $prime{$package} ) ) {
}
}
}
-
+
# Then we iterate over all the packages found above, identifying conflicts
# and selecting the "best" candidate for recording the file & version
# for each package.
foreach my $package ( keys( %alt ) ) {
my $result = $resolve_module_versions->( $alt{$package} );
-
+
if ( exists( $prime{$package} ) ) { # primary package selected
-
+
if ( $result->{err} ) {
- # Use the selected primary package, but there are conflicting
- # errors among multiple alternative packages that need to be
- # reported
+ # Use the selected primary package, but there are conflicting
+ # errors among multiple alternative packages that need to be
+ # reported
log_info {
- "Found conflicting versions for package '$package'\n" .
- " $prime{$package}{file} ($prime{$package}{version})\n" .
- $result->{err}
+ "Found conflicting versions for package '$package'\n" .
+ " $prime{$package}{file} ($prime{$package}{version})\n" .
+ $result->{err}
};
-
+
} elsif ( defined( $result->{version} ) ) {
- # There is a primary package selected, and exactly one
- # alternative package
-
- if ( exists( $prime{$package}{version} ) &&
- defined( $prime{$package}{version} ) ) {
- # Unless the version of the primary package agrees with the
- # version of the alternative package, report a conflict
- if ( $compare_versions->(
+ # There is a primary package selected, and exactly one
+ # alternative package
+
+ if ( exists( $prime{$package}{version} ) &&
+ defined( $prime{$package}{version} ) ) {
+ # Unless the version of the primary package agrees with the
+ # version of the alternative package, report a conflict
+ if ( $compare_versions->(
$prime{$package}{version}, '!=', $result->{version}
)
) {
log_info {
"Found conflicting versions for package '$package'\n" .
- " $prime{$package}{file} ($prime{$package}{version})\n" .
- " $result->{file} ($result->{version})\n"
+ " $prime{$package}{file} ($prime{$package}{version})\n" .
+ " $result->{file} ($result->{version})\n"
};
- }
-
- } else {
- # The prime package selected has no version so, we choose to
- # use any alternative package that does have a version
- $prime{$package}{file} = $result->{file};
- $prime{$package}{version} = $result->{version};
- }
-
+ }
+
} else {
- # no alt package found with a version, but we have a prime
- # package so we use it whether it has a version or not
+ # The prime package selected has no version so, we choose to
+ # use any alternative package that does have a version
+ $prime{$package}{file} = $result->{file};
+ $prime{$package}{version} = $result->{version};
}
-
+
+ } else {
+ # no alt package found with a version, but we have a prime
+ # package so we use it whether it has a version or not
+ }
+
} else { # No primary package was selected, use the best alternative
-
+
if ( $result->{err} ) {
log_info {
"Found conflicting versions for package '$package'\n" .
- $result->{err}
+ $result->{err}
};
}
-
+
# Despite possible conflicting versions, we choose to record
# something rather than nothing
$prime{$package}{file} = $result->{file};
$prime{$package}{version} = $result->{version}
- if defined( $result->{version} );
+ if defined( $result->{version} );
}
}
-
+
# Normalize versions. Can't use exists() here because of bug in YAML::Node.
- # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
+ # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18
for (grep defined $_->{version}, values %prime) {
$_->{version} = $normalize_version->( $_->{version} );
}
-
+
return \%prime;
}
-}
-
+}
+
sub _init {
my $class = shift;
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
+ if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
- if -e "$testfile.pm";
+ if -e "$testfile.pm";
}
return;
}
my $pkg = 'main';
my $pod_sect = '';
my $pod_data = '';
+ my $in_end = 0;
while (defined( my $line = <$fh> )) {
my $line_num = $.;
if ( $in_pod ) {
if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
- push( @pod, $1 );
- if ( $self->{collect_pod} && length( $pod_data ) ) {
+ push( @pod, $1 );
+ if ( $self->{collect_pod} && length( $pod_data ) ) {
$pod{$pod_sect} = $pod_data;
$pod_data = '';
}
- $pod_sect = $1;
+ $pod_sect = $1;
} elsif ( $self->{collect_pod} ) {
- $pod_data .= "$line\n";
+ $pod_data .= "$line\n";
}
} else {
+ # Skip after __END__
+ next if $in_end;
+
# Skip comments in code
next if $line =~ /^\s*#/;
# Would be nice if we could also check $in_string or something too
- last if $line =~ /^__(?:DATA|END)__$/;
+ if ($line eq '__END__') {
+ $in_end++;
+ next;
+ }
+ last if $line eq '__DATA__';
# parse $line to see if it's a $VERSION declaration
my( $vers_sig, $vers_fullname, $vers_pkg ) =
# 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;
+ 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 );
- }
+ unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
+ $vers{$vers_pkg} = $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
+ }
# 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' );
+ $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' );
+ $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
- }
+ $need_vers = 0;
+ my $v = $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
+ unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
+ $vers{$pkg} = $v;
+ }
}
-
}
-
}
if ( $self->{collect_pod} && length($pod_data) ) {
# compiletime/runtime issues with local()
my $vsub;
$pn++; # everybody gets their own package
- my $eval = qq{BEGIN { q# Hide from _packages_inside()
+ my $eval = qq{BEGIN { my \$dummy = q# Hide from _packages_inside()
#; package Module::Metadata::_version::p$pn;
use version;
no strict;
+ no warnings;
\$vsub = sub {
local $sigil$var;
};
}};
+ $eval = $1 if $eval =~ m{^(.+)}s;
+
local $^W;
# Try to get the $VERSION
eval $eval;
############################################################
# accessors
-sub name { $_[0]->{module} }
+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 filename { $_[0]->{filename} }
+sub packages_inside { @{$_[0]->{packages}} }
+sub pod_inside { @{$_[0]->{pod_headings}} }
+sub contains_pod { 0+@{$_[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};
+ exists( $self->{versions}{$mod} ) ) {
+ return $self->{versions}{$mod};
} else {
- return undef;
+ return undef;
}
}
my $self = shift;
my $sect = shift;
if ( defined( $sect ) && length( $sect ) &&
- exists( $self->{pod}{$sect} ) ) {
- return $self->{pod}{$sect};
+ exists( $self->{pod}{$sect} ) ) {
+ return $self->{pod}{$sect};
} else {
- return undef;
+ return undef;
}
}
+sub is_indexable {
+ my ($self, $package) = @_;
+
+ my @indexable_packages = grep { $_ ne 'main' } $self->packages_inside;
+
+ # check for specific package, if provided
+ return !! grep { $_ eq $package } @indexable_packages if $package;
+
+ # otherwise, check for any indexable packages at all
+ return !! @indexable_packages;
+}
+
1;
=head1 NAME
=head1 DESCRIPTION
-This module provides a standard way to gather metadata about a .pm file
-without executing unsafe code.
+This module provides a standard way to gather metadata about a .pm file through
+(mostly) static analysis and (some) code execution. When determining the
+version of a module, the C<$VERSION> assignment is C<eval>ed, as is traditional
+in the CPAN toolchain.
=head1 USAGE
=item C<< 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
+is more than one package, it makes a best guess based on the
filename. If it's a script (i.e. not a *.pm) the package name is
'main'.
Returns a list of packages. Note: this is a raw list of packages
discovered (or assumed, in the case of C<main>). It is not
filtered for C<DB>, C<main> or private packages the way the
-C<provides> method does.
+C<provides> method does. Invalid package names are not returned,
+for example "Foo:Bar". Strange but valid package names are
+returned, for example "Foo::Bar::", and are left up to the caller
+on how to handle.
=item C<< pod_inside() >>
Returns the POD data in the given section.
+=item C<< is_indexable($package) >> or C<< is_indexable() >>
+
+Returns a boolean indicating whether the package (if provided) or any package
+(otherwise) is eligible for indexing by PAUSE, the Perl Authors Upload Server.
+Note This only checks for valid C<package> declarations, and does not take any
+ownership information into account.
+
=back
=head1 AUTHOR