summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Module/Metadata.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Module/Metadata.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Module/Metadata.pm306
1 files changed, 159 insertions, 147 deletions
diff --git a/Master/tlpkg/tlperl/lib/Module/Metadata.pm b/Master/tlpkg/tlperl/lib/Module/Metadata.pm
index e352d316208..7ea1210a241 100644
--- a/Master/tlpkg/tlperl/lib/Module/Metadata.pm
+++ b/Master/tlpkg/tlperl/lib/Module/Metadata.pm
@@ -1,6 +1,6 @@
# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
# vim:ts=8:sw=2:et:sta:sts=2
-package Module::Metadata;
+package Module::Metadata; # git description: v1.000025-7-g47ca1b2
# Adapted from Perl-licensed code originally distributed with
# Module-Build by Ken Williams
@@ -9,15 +9,20 @@ package Module::Metadata;
# perl modules (assuming this may be expanded in the distant
# parrot future to look at other types of modules).
+sub __clean_eval { eval $_[0] }
use strict;
use warnings;
-our $VERSION = '1.000019';
-$VERSION = eval $VERSION;
+our $VERSION = '1.000026';
use Carp qw/croak/;
use File::Spec;
-use IO::File;
+BEGIN {
+ # Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl
+ eval {
+ require Fcntl; Fcntl->import('SEEK_SET'); 1;
+ } or *SEEK_SET = sub { 0 }
+}
use version 0.87;
BEGIN {
if ($INC{'Log/Contextual.pm'}) {
@@ -47,14 +52,14 @@ my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name
}x;
my $PKG_NAME_REGEXP = qr{ # match a package name
- (?: :: )? # a pkg name can start with aristotle
+ (?: :: )? # a pkg name can start with arisdottle
$PKG_FIRST_WORD_REGEXP # a package word
(?:
- (?: :: )+ ### aristotle (allow one or many times)
+ (?: :: )+ ### arisdottle (allow one or many times)
$PKG_ADDL_WORD_REGEXP ### a package word
)* # ^ zero, one or many times
(?:
- :: # allow trailing aristotle
+ :: # allow trailing arisdottle
)?
}x;
@@ -73,7 +78,7 @@ my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
([\$*]) # sigil - $ or *
(
( # optional leading package name
- (?:::|\')? # possibly starting like just :: (Ì la $::VERSION)
+ (?:::|\')? # possibly starting like just :: (a la $::VERSION)
(?:\w+(?:::|\'))* # Foo::Bar:: ...
)?
VERSION
@@ -87,7 +92,7 @@ my $VERS_REGEXP = qr{ # match a VERSION definition
$VARNAME_REGEXP # without parens
)
\s*
- =[^=~] # = but not ==, nor =~
+ =[^=~>] # = but not ==, nor =~, nor =>
}x;
sub new_from_file {
@@ -162,19 +167,19 @@ sub new_from_module {
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;
@@ -287,45 +292,45 @@ sub new_from_module {
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 {
+ # 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
+ # 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
@@ -333,7 +338,7 @@ sub new_from_module {
if ( $result->{err} ) {
log_info {
"Found conflicting versions for package '$package'\n" .
- $result->{err}
+ $result->{err}
};
}
@@ -341,7 +346,7 @@ sub new_from_module {
# something rather than nothing
$prime{$package}{file} = $result->{file};
$prime{$package}{version} = $result->{version}
- if defined( $result->{version} );
+ if defined( $result->{version} );
}
}
@@ -383,12 +388,14 @@ sub _init {
my $self = bless(\%data, $class);
- if ( $handle ) {
- $self->_parse_fh($handle);
- }
- else {
- $self->_parse_file();
+ if ( not $handle ) {
+ my $filename = $self->{filename};
+ open $handle, '<', $filename
+ or croak( "Can't open '$filename': $!" );
+
+ $self->_handle_bom($handle, $filename);
}
+ $self->_parse_fh($handle);
unless($self->{module} and length($self->{module})) {
my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
@@ -423,9 +430,10 @@ sub _do_find_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";
+ if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
+ $testfile .= '.pm';
+ return [ File::Spec->rel2abs( $testfile ), $dir ]
+ if -e $testfile;
}
return;
}
@@ -449,28 +457,16 @@ sub _parse_version_expression {
my $self = shift;
my $line = shift;
- my( $sig, $var, $pkg );
+ my( $sigil, $variable_name, $package);
if ( $line =~ /$VERS_REGEXP/o ) {
- ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
- if ( $pkg ) {
- $pkg = ($pkg eq '::') ? 'main' : $pkg;
- $pkg =~ s/::$//;
+ ( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
+ if ( $package ) {
+ $package = ($package eq '::') ? 'main' : $package;
+ $package =~ s/::$//;
}
}
- return ( $sig, $var, $pkg );
-}
-
-sub _parse_file {
- my $self = shift;
-
- my $filename = $self->{filename};
- my $fh = IO::File->new( $filename )
- or croak( "Can't open '$filename': $!" );
-
- $self->_handle_bom($fh, $filename);
-
- $self->_parse_fh($fh);
+ return ( $sigil, $variable_name, $package );
}
# Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
@@ -478,11 +474,11 @@ sub _parse_file {
sub _handle_bom {
my ($self, $fh, $filename) = @_;
- my $pos = $fh->getpos;
+ my $pos = tell $fh;
return unless defined $pos;
my $buf = ' ' x 2;
- my $count = $fh->read( $buf, length $buf );
+ my $count = read $fh, $buf, length $buf;
return unless defined $count and $count >= 2;
my $encoding;
@@ -492,7 +488,7 @@ sub _handle_bom {
$encoding = 'UTF-16LE';
} elsif ( $buf eq "\x{EF}\x{BB}" ) {
$buf = ' ';
- $count = $fh->read( $buf, length $buf );
+ $count = read $fh, $buf, length $buf;
if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
$encoding = 'UTF-8';
}
@@ -500,11 +496,10 @@ sub _handle_bom {
if ( defined $encoding ) {
if ( "$]" >= 5.008 ) {
- # $fh->binmode requires perl 5.10
binmode( $fh, ":encoding($encoding)" );
}
} else {
- $fh->setpos($pos)
+ seek $fh, $pos, SEEK_SET
or croak( sprintf "Can't reset position to the top of '$filename'" );
}
@@ -515,8 +510,8 @@ 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( @packages, %vers, %pod, @pod );
+ my $package = 'main';
my $pod_sect = '';
my $pod_data = '';
my $in_end = 0;
@@ -540,15 +535,15 @@ sub _parse_fh {
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";
}
@@ -576,56 +571,57 @@ sub _parse_fh {
last if $line eq '__DATA__';
# parse $line to see if it's a $VERSION declaration
- my( $vers_sig, $vers_fullname, $vers_pkg ) =
- ($line =~ /VERSION/)
+ my( $version_sigil, $version_fullname, $version_package ) =
+ index($line, 'VERSION') >= 1
? $self->_parse_version_expression( $line )
: ();
if ( $line =~ /$PKG_REGEXP/o ) {
- $pkg = $1;
- push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
- $vers{$pkg} = $2 unless exists( $vers{$pkg} );
- $need_vers = defined $2 ? 0 : 1;
+ $package = $1;
+ my $version = $2;
+ push( @packages, $package ) unless grep( $package eq $_, @packages );
+ $need_vers = defined $version ? 0 : 1;
+
+ if ( not exists $vers{$package} and defined $version ){
+ # Upgrade to a version object.
+ my $dwim_version = eval { _dwim_version($version) };
+ croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n"
+ unless defined $dwim_version; # "0" is OK!
+ $vers{$package} = $dwim_version;
+ }
# 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;
+ } elsif ( $version_fullname && $version_package ) {
+ push( @packages, $version_package ) unless grep( $version_package eq $_, @packages );
+ $need_vers = 0 if $version_package eq $package;
- unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
- $vers{$vers_pkg} =
- $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
- }
+ unless ( defined $vers{$version_package} && length $vers{$version_package} ) {
+ $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_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' );
+ } elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) {
+ $need_vers = 0;
+ my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
+ $vers{$package} = $v;
+ push( @packages, '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' );
+ } elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) {
+ $need_vers = 1;
+ $vers{main} = '';
+ push( @packages, '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;
- }
+ } elsif ( $version_fullname && $need_vers ) {
+ $need_vers = 0;
+ my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
+ unless ( defined $vers{$package} && length $vers{$package} ) {
+ $vers{$package} = $v;
+ }
}
-
}
-
}
if ( $self->{collect_pod} && length($pod_data) ) {
@@ -633,7 +629,7 @@ sub _parse_fh {
}
$self->{versions} = \%vers;
- $self->{packages} = \@pkgs;
+ $self->{packages} = \@packages;
$self->{pod} = \%pod;
$self->{pod_headings} = \@pod;
}
@@ -642,50 +638,47 @@ sub _parse_fh {
my $pn = 0;
sub _evaluate_version_line {
my $self = shift;
- my( $sigil, $var, $line ) = @_;
-
- # Some of this code came from the ExtUtils:: hierarchy.
+ my( $sigil, $variable_name, $line ) = @_;
- # We compile into $vsub because 'use version' would cause
+ # We compile into a local sub because 'use version' would cause
# compiletime/runtime issues with local()
- my $vsub;
$pn++; # everybody gets their own package
- my $eval = qq{BEGIN { my \$dummy = q# Hide from _packages_inside()
- #; package Module::Metadata::_version::p$pn;
+ my $eval = qq{ my \$dummy = q# Hide from _packages_inside()
+ #; package Module::Metadata::_version::p${pn};
use version;
- no strict;
- no warnings;
-
- \$vsub = sub {
- local $sigil$var;
- \$$var=undef;
- $line;
- \$$var
- };
- }};
+ sub {
+ local $sigil$variable_name;
+ $line;
+ \$$variable_name
+ };
+ };
$eval = $1 if $eval =~ m{^(.+)}s;
local $^W;
# Try to get the $VERSION
- eval $eval;
- # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
+ my $vsub = __clean_eval($eval);
+ # some modules say $VERSION <equal sign> $Foo::Bar::VERSION, but Foo::Bar isn't
# installed, so we need to hunt in ./lib for it
if ( $@ =~ /Can't locate/ && -d 'lib' ) {
local @INC = ('lib',@INC);
- eval $eval;
+ $vsub = __clean_eval($eval);
}
warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
if $@;
+
(ref($vsub) eq 'CODE') or
croak "failed to build version sub for $self->{filename}";
+
my $result = eval { $vsub->() };
+ # FIXME: $eval is not the right thing to print here
croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
if $@;
# Upgrade it into a version object
my $version = eval { _dwim_version($result) };
+ # FIXME: $eval is not the right thing to print here
croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
unless defined $version; # "0" is OK!
@@ -765,10 +758,10 @@ sub version {
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;
}
}
@@ -776,13 +769,25 @@ sub pod {
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
@@ -956,7 +961,7 @@ Log::Contextual has already been loaded, otherwise simply calls warn.
=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'.
@@ -993,6 +998,13 @@ Returns true if there is any POD in the file.
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