summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPAN
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPAN')
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm1
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Distribution.pm94
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Distroprefs.pm8
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm50
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_process_error.pm53
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/FTP.pm12
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm48
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm6
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm22
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Index.pm12
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Meta.pm50
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm118
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm9
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Meta/History.pm12
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm27
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Meta/Requirements.pm680
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm44
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm105
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm62
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm439
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Shell.pm9
21 files changed, 1482 insertions, 379 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm b/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm
index b9b4eeb32bf..23e756e75b2 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm
@@ -49,6 +49,7 @@ sub tidyup {
$self->_clean_cache($toremove);
return if $CPAN::Signal;
}
+ $self->{FIFO} = [];
}
#-> sub CPAN::CacheMgr::dir ;
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm b/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm
index 637ab277d96..32648ecc1ff 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm
@@ -8,7 +8,7 @@ use CPAN::InfoObj;
use File::Path ();
@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
use vars qw($VERSION);
-$VERSION = "1.9602_01";
+$VERSION = "1.9602";
# Accessors
sub cpan_comment {
@@ -158,7 +158,7 @@ sub tested_ok_but_not_installed {
||
$self->{install}->failed
)
- );
+ );
}
@@ -741,7 +741,7 @@ sub choose_MM_or_MB {
$prefer_installer = CPAN::HandleConfig->prefs_lookup(
$self, q{prefer_installer}
);
- # M::B <= 0.35 left a DATA handle open that
+ # M::B <= 0.35 left a DATA handle open that
# causes problems upgrading M::B on Windows
close *Module::Build::Version::DATA
if fileno *Module::Build::Version::DATA;
@@ -777,6 +777,12 @@ sub choose_MM_or_MB {
sub store_persistent_state {
my($self) = @_;
my $dir = $self->{build_dir};
+ unless (defined $dir && length $dir) {
+ my $id = $self->id;
+ $CPAN::Frontend->mywarnonce("build_dir of $id is not known, ".
+ "will not store persistent state\n");
+ return;
+ }
unless (File::Spec->canonpath(File::Basename::dirname($dir))
eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
$CPAN::Frontend->mywarnonce("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
@@ -859,7 +865,7 @@ sub try_download {
}
}
my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
- $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
+ $CPAN::Frontend->myprint("Applying $countedpatches:\n");
my $patches_dir = $CPAN::Config->{patches_dir};
for my $patch (@$patches) {
if ($patches_dir && !File::Spec->file_name_is_absolute($patch)) {
@@ -1845,7 +1851,7 @@ is part of the perl-%s distribution. To install that, you need to run
delete $self->{force_update};
return;
}
- $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
+ $CPAN::Frontend->myprint("\n CPAN.pm: Building ".$self->id."\n\n");
$self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
@@ -2886,8 +2892,8 @@ sub read_yaml {
if $CPAN::DEBUG;
$self->debug($yaml) if $CPAN::DEBUG && $yaml;
# MYMETA.yml is static and authoritative by definition
- if ( $meta_file =~ /MYMETA\.yml/ ) {
- return $yaml;
+ if ( $meta_file =~ /MYMETA\.yml/ ) {
+ return $yaml;
}
# META.yml is authoritative only if dynamic_config is defined and false
if ( defined $yaml->{dynamic_config} && ! $yaml->{dynamic_config} ) {
@@ -3167,7 +3173,7 @@ sub test {
# bypass actual tests if "trust_test_report_history" and have a report
my $have_tested_fcn;
if ( $CPAN::Config->{trust_test_report_history}
- && $CPAN::META->has_inst("CPAN::Reporter::History")
+ && $CPAN::META->has_inst("CPAN::Reporter::History")
&& ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
# Do nothing if grade was DISCARD
@@ -3287,43 +3293,43 @@ sub test {
sub _make_test_illuminate_prereqs {
my($self) = @_;
- my @prereq;
-
- # local $CPAN::DEBUG = 16; # Distribution
- for my $m (keys %{$self->{sponsored_mods}}) {
- next unless $self->{sponsored_mods}{$m} > 0;
- my $m_obj = CPAN::Shell->expand("Module",$m) or next;
- # XXX we need available_version which reflects
- # $ENV{PERL5LIB} so that already tested but not yet
- # installed modules are counted.
- my $available_version = $m_obj->available_version;
- my $available_file = $m_obj->available_file;
- if ($available_version &&
- !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
- ) {
- CPAN->debug("m[$m] good enough available_version[$available_version]")
- if $CPAN::DEBUG;
- } elsif ($available_file
- && (
- !$self->{prereq_pm}{$m}
- ||
- $self->{prereq_pm}{$m} == 0
- )
- ) {
- # lex Class::Accessor::Chained::Fast which has no $VERSION
- CPAN->debug("m[$m] have available_file[$available_file]")
- if $CPAN::DEBUG;
- } else {
- push @prereq, $m;
- }
- }
+ my @prereq;
+
+ # local $CPAN::DEBUG = 16; # Distribution
+ for my $m (keys %{$self->{sponsored_mods}}) {
+ next unless $self->{sponsored_mods}{$m} > 0;
+ my $m_obj = CPAN::Shell->expand("Module",$m) or next;
+ # XXX we need available_version which reflects
+ # $ENV{PERL5LIB} so that already tested but not yet
+ # installed modules are counted.
+ my $available_version = $m_obj->available_version;
+ my $available_file = $m_obj->available_file;
+ if ($available_version &&
+ !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
+ ) {
+ CPAN->debug("m[$m] good enough available_version[$available_version]")
+ if $CPAN::DEBUG;
+ } elsif ($available_file
+ && (
+ !$self->{prereq_pm}{$m}
+ ||
+ $self->{prereq_pm}{$m} == 0
+ )
+ ) {
+ # lex Class::Accessor::Chained::Fast which has no $VERSION
+ CPAN->debug("m[$m] have available_file[$available_file]")
+ if $CPAN::DEBUG;
+ } else {
+ push @prereq, $m;
+ }
+ }
my $but;
- if (@prereq) {
- my $cnt = @prereq;
- my $which = join ",", @prereq;
+ if (@prereq) {
+ my $cnt = @prereq;
+ my $which = join ",", @prereq;
$but = $cnt == 1 ? "one dependency not OK ($which)" :
- "$cnt dependencies missing ($which)";
- }
+ "$cnt dependencies missing ($which)";
+ }
$but;
}
@@ -3669,7 +3675,7 @@ sub perldoc {
$CPAN::Frontend->myprint(qq{
Function system("@args")
returned status $estatus (wstat $wstatus)
- });
+ });
}
}
else {
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Distroprefs.pm b/Master/tlpkg/tlperl/lib/CPAN/Distroprefs.pm
index e1be9cdf749..61c389ed2d3 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Distroprefs.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Distroprefs.pm
@@ -169,7 +169,7 @@ sub find {
file => $_, ext => $ext, dir => $dir
});
# copied from CPAN.pm; is this ever actually possible?
- redo unless -f $result->abs;
+ redo unless -f $result->abs;
my $load_method = $self->_load_method($loader, $result);
my @prefs = eval { $self->$load_method($loader, $result) };
@@ -314,7 +314,7 @@ __END__
CPAN::Distroprefs -- read and match distroprefs
-=head1 SYNOPSIS
+=head1 SYNOPSIS
use CPAN::Distroprefs;
@@ -381,7 +381,7 @@ All results share some common attributes:
C<success>, C<warning>, or C<fatal>
-=head3 file
+=head3 file
the file from which these prefs were read, or to which this error refers (relative filename)
@@ -413,7 +413,7 @@ Success results contain:
an arrayref of CPAN::Distroprefs::Pref objects
-=head1 PREFS
+=head1 PREFS
CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
They are constructed automatically as part of C<success> results from C<find()>.
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm b/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm
index e1259e5397d..1e7fa83a53b 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm
@@ -20,54 +20,4 @@ sub as_string {
"'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
}
-package CPAN::Exception::yaml_process_error;
-use strict;
-use overload '""' => "as_string";
-
-use vars qw(
- $VERSION
-);
-$VERSION = "5.5";
-
-
-sub new {
- my($class,$module,$file,$during,$error) = @_;
- # my $at = Carp::longmess(""); # XXX find something more beautiful
- bless { module => $module,
- file => $file,
- during => $during,
- error => $error,
- # at => $at,
- }, $class;
-}
-
-sub as_string {
- my($self) = shift;
- if ($self->{during}) {
- if ($self->{file}) {
- if ($self->{module}) {
- if ($self->{error}) {
- return "Alert: While trying to '$self->{during}' YAML file\n".
- " '$self->{file}'\n".
- "with '$self->{module}' the following error was encountered:\n".
- " $self->{error}\n";
- } else {
- return "Alert: While trying to '$self->{during}' YAML file\n".
- " '$self->{file}'\n".
- "with '$self->{module}' some unknown error was encountered\n";
- }
- } else {
- return "Alert: While trying to '$self->{during}' YAML file\n".
- " '$self->{file}'\n".
- "some unknown error was encountered\n";
- }
- } else {
- return "Alert: While trying to '$self->{during}' some YAML file\n".
- "some unknown error was encountered\n";
- }
- } else {
- return "Alert: unknown error encountered\n";
- }
-}
-
1;
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_process_error.pm b/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_process_error.pm
new file mode 100644
index 00000000000..ae8c14ebebe
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_process_error.pm
@@ -0,0 +1,53 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Exception::yaml_process_error;
+use strict;
+use overload '""' => "as_string";
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+
+sub new {
+ my($class,$module,$file,$during,$error) = @_;
+ # my $at = Carp::longmess(""); # XXX find something more beautiful
+ bless { module => $module,
+ file => $file,
+ during => $during,
+ error => $error,
+ # at => $at,
+ }, $class;
+}
+
+sub as_string {
+ my($self) = shift;
+ if ($self->{during}) {
+ if ($self->{file}) {
+ if ($self->{module}) {
+ if ($self->{error}) {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "with '$self->{module}' the following error was encountered:\n".
+ " $self->{error}\n";
+ } else {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "with '$self->{module}' some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: While trying to '$self->{during}' some YAML file\n".
+ "some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: unknown error encountered\n";
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CPAN/FTP.pm b/Master/tlpkg/tlperl/lib/CPAN/FTP.pm
index 4f233814e54..997e141be5a 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/FTP.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/FTP.pm
@@ -21,6 +21,11 @@ $VERSION = "5.5005";
sub _ftp_statistics {
my($self,$fh) = @_;
my $locktype = $fh ? LOCK_EX : LOCK_SH;
+ # XXX On Windows flock() implements mandatory locking, so we can
+ # XXX only use shared locking to still allow _yaml_load_file() to
+ # XXX read from the file using a different filehandle.
+ $locktype = LOCK_SH if $^O eq "MSWin32";
+
$fh ||= FileHandle->new;
my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
mkpath dirname $file;
@@ -56,6 +61,7 @@ sub _ftp_statistics {
$CPAN::Frontend->mydie($@);
}
}
+ CPAN::_flock($fh, LOCK_UN);
return $stats->[0];
}
@@ -567,7 +573,7 @@ sub hostdleasy { #called from hostdlxxx
$ThesiteURL = $ro_url;
return $l;
}
- # If request is for a compressed file and we can find the
+ # If request is for a compressed file and we can find the
# uncompressed file also, return the path of the uncompressed file
# otherwise, decompress it and return the resulting path
if ($l =~ /(.+)\.gz$/) {
@@ -975,7 +981,7 @@ ftp config variable with
Trying with external ftp to get
'$url'
$netrc_explain
- Going to send the dialog
+ Sending the dialog
$dialog
}
);
@@ -1014,7 +1020,7 @@ $dialog
$CPAN::Frontend->myprint(qq{
Trying with external ftp to get
$url
- Going to send the dialog
+ Sending the dialog
$dialog
}
);
diff --git a/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm b/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm
index 667bdca2f9a..5030ef9b838 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm
@@ -202,8 +202,8 @@ Preferred method for determining the current working directory?
=item halt_on_failure
Normally, CPAN.pm continues processing the full list of targets and
-dependencies, even if one of them fails. However, you can specify
-that CPAN should halt after the first failure.
+dependencies, even if one of them fails. However, you can specify
+that CPAN should halt after the first failure.
Do you want to halt on failure (yes/no)?
@@ -339,7 +339,7 @@ Your choice:
Parameters for the './Build install' command? Typical frequently used
setting:
- --uninst 1 # uninstall conflicting files
+ --uninst 1 # uninstall conflicting files
# (but do NOT use with local::lib or INSTALL_BASE)
Your choice:
@@ -781,8 +781,8 @@ sub init {
if ( $args{autoconfig} ) {
$auto_config = 1;
} elsif ($matcher) {
- $auto_config = 0;
- } else {
+ $auto_config = 0;
+ } else {
my $_conf = prompt($prompts{auto_config}, "yes");
$auto_config = ($_conf and $_conf =~ /^y/i) ? 1 : 0;
}
@@ -795,7 +795,7 @@ sub init {
my $i_am_mad = 0;
# silent prompting -- just quietly use default
*_real_prompt = sub { return $_[1] };
- }
+ }
#
# bootstrap local::lib or sudo
@@ -993,8 +993,8 @@ sub init {
my_dflt_prompt(makepl_arg => "", $matcher);
my_dflt_prompt(make_arg => "", $matcher);
if ( $CPAN::Config->{makepl_arg} =~ /LIBS=|INC=/ ) {
- $CPAN::Frontend->mywarn(
- "Warning: Using LIBS or INC in makepl_arg will likely break distributions\n" .
+ $CPAN::Frontend->mywarn(
+ "Warning: Using LIBS or INC in makepl_arg will likely break distributions\n" .
"that specify their own LIBS or INC options in Makefile.PL.\n"
);
}
@@ -1224,9 +1224,9 @@ sub init {
);
}
else {
- $CPAN::Frontend->myprint(
- "Autoconfigured everything but 'urllist'.\n"
- );
+ $CPAN::Frontend->myprint(
+ "Autoconfigured everything but 'urllist'.\n"
+ );
_do_pick_mirrors();
}
}
@@ -1247,8 +1247,8 @@ sub init {
$CPAN::Frontend->myprint(
"Skipping local::lib bootstrap because 'urllist' is not configured.\n"
);
- }
- else {
+ }
+ else {
$CPAN::Frontend->myprint("\nAttempting to bootstrap local::lib...\n");
$CPAN::Frontend->myprint("\nWriting $configpm for bootstrap...\n");
delete $CPAN::Config->{install_help}; # temporary only
@@ -1268,11 +1268,11 @@ sub init {
$CPAN::Frontend->myprint("From the CPAN Shell, you might try 'look local::lib' and \n"
. "run 'perl Makefile --bootstrap' and see if that is successful. Then\n"
. "restart your CPAN client\n"
- );
+ );
}
else {
_local_lib_config();
- }
+ }
}
}
@@ -1515,7 +1515,7 @@ ALERT: 'make' is an essential tool for building perl Modules.
Please make sure you have 'make' (or some equivalent) working.
HERE
- if ($^O eq "MSWin32") {
+ if ($^O eq "MSWin32") {
$CPAN::Frontend->mywarn(<<"HERE");
Windows users may want to follow this procedure when back in the CPAN shell:
@@ -1528,7 +1528,7 @@ substitute. You can then revisit this dialog with
o conf init make
HERE
- }
+ }
}
sub init_cpan_home {
@@ -1657,7 +1657,7 @@ sub my_prompt_loop {
# (2) We don't have a copy at all
# (2a) If we are allowed to connect, we try to get a new copy. If it succeeds,
# we use it, otherwise, we warn about failure
-# (2b) If we aren't allowed to connect,
+# (2b) If we aren't allowed to connect,
sub conf_sites {
my %args = @_;
@@ -1732,7 +1732,7 @@ HERE
}
else {
$CPAN::Frontend->mywarn(<<'HERE');
-You will need to provide CPAN mirror URLs yourself or set
+You will need to provide CPAN mirror URLs yourself or set
'o conf connect_to_internet_ok 1' and try again.
HERE
}
@@ -1851,7 +1851,9 @@ sub auto_mirrored_by {
my $local = shift or return;
local $|=1;
$CPAN::Frontend->myprint("Looking for CPAN mirrors near you (please be patient)\n");
- my $mirrors = CPAN::Mirrors->new($local);
+ my $mirrors = CPAN::Mirrors->new;
+ $mirrors->parse_mirrored_by($local);
+
my $cnt = 0;
my @best = $mirrors->best_mirrors(
how_many => 3,
@@ -1860,9 +1862,11 @@ sub auto_mirrored_by {
if ($cnt++>60) { $cnt=0; $CPAN::Frontend->myprint("\n"); }
},
);
+
my $urllist = [ map { $_->http } @best ];
push @$urllist, grep { /^file:/ } @{$CPAN::Config->{urllist}};
$CPAN::Frontend->myprint(" done!\n\n");
+
return $urllist
}
@@ -1998,8 +2002,8 @@ later if you\'re sure it\'s right.\n},
sub _print_urllist {
my ($which) = @_;
$CPAN::Frontend->myprint("$which urllist\n");
- for ( @{$CPAN::Config->{urllist} || []} ) {
- $CPAN::Frontend->myprint(" $_\n")
+ for ( @{$CPAN::Config->{urllist} || []} ) {
+ $CPAN::Frontend->myprint(" $_\n")
};
}
diff --git a/Master/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm b/Master/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm
index 52de7fe237c..c5eb0f6a435 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm
@@ -31,8 +31,8 @@ sub mirror {
my($self, $uri, $path) = @_;
my $want_proxy = $self->_want_proxy($uri);
- my $http = HTTP::Tiny->new(
- $want_proxy ? (proxy => $self->{proxy}) : ()
+ my $http = HTTP::Tiny->new(
+ $want_proxy ? (proxy => $self->{proxy}) : ()
);
my ($response, %headers);
@@ -112,7 +112,7 @@ sub _get_challenge {
my $auth_list = $response->{headers}(lc $auth_header);
return unless defined $auth_list;
$auth_list = [$auth_list] unless ref $auth_list;
-
+
for my $challenge (@$auth_list) {
$challenge =~ tr/,/;/; # "," is used to separate auth-params!!
($challenge) = $self->split_header_words($challenge);
diff --git a/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm b/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm
index 58ccbe50e5d..09c42efee08 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm
@@ -265,11 +265,11 @@ sub commit {
my($self,@args) = @_;
CPAN->debug("args[@args]") if $CPAN::DEBUG;
if ($CPAN::RUN_DEGRADED) {
- $CPAN::Frontend->mydie(
- "'o conf commit' disabled in ".
- "degraded mode. Maybe try\n".
- " !undef \$CPAN::RUN_DEGRADED\n"
- );
+ $CPAN::Frontend->mydie(
+ "'o conf commit' disabled in ".
+ "degraded mode. Maybe try\n".
+ " !undef \$CPAN::RUN_DEGRADED\n"
+ );
}
my ($configpm, $must_reload);
@@ -474,13 +474,13 @@ sub init {
sub require_myconfig_or_config () {
if ( $INC{"CPAN/MyConfig.pm"} || _try_loading("CPAN::MyConfig", cpan_home())) {
return $INC{"CPAN/MyConfig.pm"};
- }
+ }
elsif ( $INC{"CPAN/Config.pm"} || _try_loading("CPAN::Config") ) {
return $INC{"CPAN/Config.pm"};
- }
+ }
else {
return q{};
- }
+ }
}
# Load a module, but ignore "can't locate..." errors
@@ -495,8 +495,8 @@ sub _try_loading {
if ( -f File::Spec->catfile($dir, $file) ) {
unshift @INC, $dir;
last;
+ }
}
- }
eval { require $file };
my $err_myconfig = $@;
@@ -515,7 +515,7 @@ sub cpan_home_dir_candidates {
if ($^O ne 'darwin') {
push @dirs, File::HomeDir->my_data;
# my_data is ~/Library/Application Support on darwin,
- # which causes issues in the toolchain.
+ # which causes issues in the toolchain.
}
push @dirs, File::HomeDir->my_home;
}
@@ -592,7 +592,7 @@ sub make_new_config {
Old configuration file $configpm
moved to $configpm_bak
END
- }
+ }
}
my $fh = FileHandle->new;
if ($fh->open(">$configpm")) {
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Index.pm b/Master/tlpkg/tlperl/lib/CPAN/Index.pm
index 4fcde8c390d..af98d7bf15c 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Index.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Index.pm
@@ -132,7 +132,7 @@ sub reanimate_build_dir {
return;
}
$CPAN::Frontend->myprint
- (sprintf("Going to read %d yaml file%s from %s/\n",
+ (sprintf("Reading %d yaml file%s from %s/\n",
scalar @candidates,
@candidates==1 ? "" : "s",
$CPAN::Config->{build_dir}
@@ -231,7 +231,7 @@ sub rd_authindex {
return unless defined $index_target;
return if CPAN::_sqlite_running();
my @lines;
- $CPAN::Frontend->myprint("Going to read '$index_target'\n");
+ $CPAN::Frontend->myprint("Reading '$index_target'\n");
local(*FH);
tie *FH, 'CPAN::Tarzip', $index_target;
local($/) = "\n";
@@ -271,7 +271,7 @@ sub rd_modpacks {
my($self, $index_target) = @_;
return unless defined $index_target;
return if CPAN::_sqlite_running();
- $CPAN::Frontend->myprint("Going to read '$index_target'\n");
+ $CPAN::Frontend->myprint("Reading '$index_target'\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
@@ -494,7 +494,7 @@ sub rd_modlist {
my($cl,$index_target) = @_;
return unless defined $index_target;
return if CPAN::_sqlite_running();
- $CPAN::Frontend->myprint("Going to read '$index_target'\n");
+ $CPAN::Frontend->myprint("Reading '$index_target'\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
my $slurp = "";
@@ -556,7 +556,7 @@ sub write_metadata_cache {
$cache->{last_time} = $LAST_TIME;
$cache->{DATE_OF_02} = $DATE_OF_02;
$cache->{PROTOCOL} = PROTOCOL;
- $CPAN::Frontend->myprint("Going to write $metadata_file\n");
+ $CPAN::Frontend->myprint("Writing $metadata_file\n");
eval { Storable::nstore($cache, $metadata_file) };
$CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
}
@@ -569,7 +569,7 @@ sub read_metadata_cache {
return unless $CPAN::META->has_usable("Storable");
my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
return unless -r $metadata_file and -f $metadata_file;
- $CPAN::Frontend->myprint("Going to read '$metadata_file'\n");
+ $CPAN::Frontend->myprint("Reading '$metadata_file'\n");
my $cache;
eval { $cache = Storable::retrieve($metadata_file) };
$CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta.pm
index ef798559fb4..f8185983a42 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Meta.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Meta.pm
@@ -2,10 +2,7 @@ use 5.006;
use strict;
use warnings;
package CPAN::Meta;
-BEGIN {
- $CPAN::Meta::VERSION = '2.110440';
-}
-# ABSTRACT: the distribution metadata for a CPAN dist
+our $VERSION = '2.120630'; # VERSION
use Carp qw(carp croak);
@@ -13,7 +10,9 @@ use CPAN::Meta::Feature;
use CPAN::Meta::Prereqs;
use CPAN::Meta::Converter;
use CPAN::Meta::Validator;
-use Parse::CPAN::Meta 1.44 ();
+use Parse::CPAN::Meta 1.4400 ();
+
+BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone }
BEGIN {
@@ -47,7 +46,7 @@ BEGIN {
my $value = $_[0]{ $attr };
croak "$attr must be called in list context"
unless wantarray;
- return @{ Storable::dclone($value) } if ref $value;
+ return @{ _dclone($value) } if ref $value;
return $value;
};
}
@@ -73,7 +72,7 @@ BEGIN {
(my $subname = $attr) =~ s/-/_/;
*$subname = sub {
my $value = $_[0]{ $attr };
- return Storable::dclone($value) if $value;
+ return _dclone($value) if $value;
return {};
};
}
@@ -87,7 +86,7 @@ sub custom_keys {
sub custom {
my ($self, $attr) = @_;
my $value = $self->{$attr};
- return Storable::dclone($value) if ref $value;
+ return _dclone($value) if ref $value;
return $value;
}
@@ -215,7 +214,6 @@ sub save {
}
-# XXX Do we need this if we always upconvert? -- dagolden, 2010-04-14
sub meta_spec_version {
my ($self) = @_;
return $self->meta_spec->{version};
@@ -290,10 +288,7 @@ sub feature {
sub as_struct {
my ($self, $options) = @_;
- my $backend = Parse::CPAN::Meta->json_backend();
- my $struct = $backend->new->decode(
- $backend->new->convert_blessed->encode($self)
- );
+ my $struct = _dclone($self);
if ( $options->{version} ) {
my $cmc = CPAN::Meta::Converter->new( $struct );
$struct = $cmc->convert( version => $options->{version} );
@@ -308,7 +303,7 @@ sub as_string {
my $version = $options->{version} || '2';
my $struct;
- if ( $self->version ne $version ) {
+ if ( $self->meta_spec_version ne $version ) {
my $cmc = CPAN::Meta::Converter->new( $self->as_struct );
$struct = $cmc->convert( version => $version );
}
@@ -339,6 +334,8 @@ sub TO_JSON {
1;
+# ABSTRACT: the distribution metadata for a CPAN dist
+
=pod
@@ -349,7 +346,7 @@ CPAN::Meta - the distribution metadata for a CPAN dist
=head1 VERSION
-version 2.110440
+version 2.120630
=head1 SYNOPSIS
@@ -644,6 +641,10 @@ particular keys may be retrieved with the C<custom> method.
If a custom key refers to a data structure, a deep clone is returned.
+=for Pod::Coverage TO_JSON abstract author authors custom custom_keys description dynamic_config
+generated_by keywords license licenses meta_spec name no_index
+optional_features prereqs provides release_status resources version
+
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
@@ -667,6 +668,25 @@ L<CPAN::Meta::Validator>
=back
+=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
+
+=head1 SUPPORT
+
+=head2 Bugs / Feature Requests
+
+Please report any bugs or feature requests through the issue tracker
+at L<http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta>.
+You will be notified automatically of any progress on your issue.
+
+=head2 Source Code
+
+This is open source software. The code repository is available for
+public review and contribution under the terms of the license.
+
+L<http://github.com/dagolden/cpan-meta>
+
+ git clone git://github.com/dagolden/cpan-meta.git
+
=head1 AUTHORS
=over 4
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm
index 2c6ce857d3d..0348e55504e 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm
@@ -2,15 +2,29 @@ use 5.006;
use strict;
use warnings;
package CPAN::Meta::Converter;
-BEGIN {
- $CPAN::Meta::Converter::VERSION = '2.110440';
-}
-# ABSTRACT: Convert CPAN distribution metadata structures
+our $VERSION = '2.120630'; # VERSION
use CPAN::Meta::Validator;
-use Storable qw/dclone/;
-use version 0.82 ();
+use CPAN::Meta::Requirements;
+use version 0.88 ();
+use Parse::CPAN::Meta 1.4400 ();
+
+sub _dclone {
+ my $ref = shift;
+
+ # if an object is in the data structure and doesn't specify how to
+ # turn itself into JSON, we just stringify the object. That does the
+ # right thing for typical things that might be there, like version objects,
+ # Path::Class objects, etc.
+ no warnings 'once';
+ local *UNIVERSAL::TO_JSON = sub { return "$_[0]" };
+
+ my $backend = Parse::CPAN::Meta->json_backend();
+ return $backend->new->utf8->decode(
+ $backend->new->utf8->allow_blessed->convert_blessed->encode($ref)
+ );
+}
my %known_specs = (
'2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
@@ -134,15 +148,18 @@ my @valid_licenses_2 = qw(
unknown
);
+# The "old" values were defined by Module::Build, and were often vague. I have
+# made the decisions below based on reading Module::Build::API and how clearly
+# it specifies the version of the license.
my %license_map_2 = (
- ( map { $_ => $_ } @valid_licenses_2 ),
- apache => 'apache_2_0',
- artistic => 'artistic_1',
- artistic2 => 'artistic_2',
- gpl => 'gpl_1',
- lgpl => 'lgpl_2_1',
- mozilla => 'mozilla_1_0',
- perl => 'perl_5',
+ (map { $_ => $_ } @valid_licenses_2),
+ apache => 'apache_2_0', # clearly stated as 2.0
+ artistic => 'artistic_1', # clearly stated as 1
+ artistic2 => 'artistic_2', # clearly stated as 2
+ gpl => 'open_source', # we don't know which GPL; punt
+ lgpl => 'open_source', # we don't know which LGPL; punt
+ mozilla => 'open_source', # we don't know which MPL; punt
+ perl => 'perl_5', # clearly Perl 5
restrictive => 'restricted',
);
@@ -300,7 +317,10 @@ sub _clean_version {
return 0 if ! length $element;
return 0 if ( $element eq 'undef' || $element eq '<undef>' );
- if ( my $v = eval { version->new($element) } ) {
+ my $v = eval { version->new($element) };
+ # XXX check defined $v and not just $v because version objects leak memory
+ # in boolean context -- dagolden, 2012-02-03
+ if ( defined $v ) {
return $v->is_qv ? $v->normal : $element;
}
else {
@@ -308,29 +328,36 @@ sub _clean_version {
}
}
+sub _bad_version_hook {
+ my ($v) = @_;
+ $v =~ s{[a-z]+$}{}; # strip trailing alphabetics
+ my $vobj = eval { version->parse($v) };
+ return defined($vobj) ? $vobj : version->parse(0); # or give up
+}
+
sub _version_map {
my ($element) = @_;
- return undef unless defined $element;
+ return unless defined $element;
if ( ref $element eq 'HASH' ) {
- my $new_map = {};
- for my $k ( keys %$element ) {
+ # XXX turn this into CPAN::Meta::Requirements with bad version hook
+ # and then turn it back into a hash
+ my $new_map = CPAN::Meta::Requirements->new(
+ { bad_version_hook => sub { version->new(0) } } # punt
+ );
+ while ( my ($k,$v) = each %$element ) {
next unless _is_module_name($k);
- my $value = $element->{$k};
- if ( ! ( defined $value && length $value ) ) {
- $new_map->{$k} = 0;
- }
- elsif ( $value eq 'undef' || $value eq '<undef>' ) {
- $new_map->{$k} = 0;
+ if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>' ) {
+ $v = 0;
}
- elsif ( _is_module_name( $value ) ) { # some weird, old META have this
- $new_map->{$k} = 0;
- $new_map->{$value} = 0;
- }
- else {
- $new_map->{$k} = _clean_version($value);
+ # some weird, old META have bad yml with module => module
+ # so check if value is like a module name and not like a version
+ if ( _is_module_name($v) && ! version::is_lax($v) ) {
+ $new_map->add_minimum($k => 0);
+ $new_map->add_minimum($v => 0);
}
+ $new_map->add_string_requirement($k => $v);
}
- return $new_map;
+ return $new_map->as_string_hash;
}
elsif ( ref $element eq 'ARRAY' ) {
my $hashref = { map { $_ => 0 } @$element };
@@ -413,9 +440,8 @@ sub _get_build_requires {
my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {};
my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};
- require Version::Requirements;
- my $test_req = Version::Requirements->from_string_hash($test_h);
- my $build_req = Version::Requirements->from_string_hash($build_h);
+ my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h);
+ my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);
$test_req->add_requirements($build_req)->as_string_hash;
}
@@ -423,12 +449,12 @@ sub _get_build_requires {
sub _extract_prereqs {
my ($prereqs, $phase, $type) = @_;
return unless ref $prereqs eq 'HASH';
- return $prereqs->{$phase}{$type};
+ return scalar _version_map($prereqs->{$phase}{$type});
}
sub _downgrade_optional_features {
my (undef, undef, $meta) = @_;
- return undef unless exists $meta->{optional_features};
+ return unless exists $meta->{optional_features};
my $origin = $meta->{optional_features};
my $features = {};
for my $name ( keys %$origin ) {
@@ -449,7 +475,7 @@ sub _downgrade_optional_features {
sub _upgrade_optional_features {
my (undef, undef, $meta) = @_;
- return undef unless exists $meta->{optional_features};
+ return unless exists $meta->{optional_features};
my $origin = $meta->{optional_features};
my $features = {};
for my $name ( keys %$origin ) {
@@ -545,7 +571,7 @@ my $resource2_upgrade = {
return unless $item;
if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } }
elsif( _is_urlish($item) ) { return { web => $item } }
- else { return undef }
+ else { return }
},
repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef },
':custom' => \&_prefix_custom,
@@ -553,7 +579,7 @@ my $resource2_upgrade = {
sub _upgrade_resources_2 {
my (undef, undef, $meta, $version) = @_;
- return undef unless exists $meta->{resources};
+ return unless exists $meta->{resources};
return _convert($meta->{resources}, $resource2_upgrade);
}
@@ -591,7 +617,7 @@ my $resources2_cleanup = {
sub _cleanup_resources_2 {
my ($resources, $key, $meta, $to_version) = @_;
- return undef unless $resources && ref $resources eq 'HASH';
+ return unless $resources && ref $resources eq 'HASH';
return _convert($resources, $resources2_cleanup, $to_version);
}
@@ -605,7 +631,7 @@ my $resource1_spec = {
sub _resources_1_3 {
my (undef, undef, $meta, $version) = @_;
- return undef unless exists $meta->{resources};
+ return unless exists $meta->{resources};
return _convert($meta->{resources}, $resource1_spec);
}
@@ -618,7 +644,7 @@ sub _resources_1_2 {
$resources->{license} = $meta->license_url
if _is_urlish($meta->{license_url});
}
- return undef unless keys %$resources;
+ return unless keys %$resources;
return _convert($resources, $resource1_spec);
}
@@ -632,7 +658,7 @@ my $resource_downgrade_spec = {
sub _downgrade_resources {
my (undef, undef, $meta, $version) = @_;
- return undef unless exists $meta->{resources};
+ return unless exists $meta->{resources};
return _convert($meta->{resources}, $resource_downgrade_spec);
}
@@ -1187,7 +1213,7 @@ sub convert {
my $new_version = $args->{version} || $HIGHEST;
my ($old_version) = $self->{spec};
- my $converted = dclone $self->{data};
+ my $converted = _dclone($self->{data});
if ( $old_version == $new_version ) {
$converted = _convert( $converted, $cleanup{$old_version}, $old_version );
@@ -1232,6 +1258,8 @@ sub convert {
1;
+# ABSTRACT: Convert CPAN distribution metadata structures
+
=pod
@@ -1242,7 +1270,7 @@ CPAN::Meta::Converter - Convert CPAN distribution metadata structures
=head1 VERSION
-version 2.110440
+version 2.120630
=head1 SYNOPSIS
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm
index d3575e5e7e8..cd7689e9a67 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm
@@ -2,10 +2,7 @@ use 5.006;
use strict;
use warnings;
package CPAN::Meta::Feature;
-BEGIN {
- $CPAN::Meta::Feature::VERSION = '2.110440';
-}
-# ABSTRACT: an optional feature provided by a CPAN distribution
+our $VERSION = '2.120630'; # VERSION
use CPAN::Meta::Prereqs;
@@ -33,6 +30,8 @@ sub prereqs { $_[0]{prereqs} }
1;
+# ABSTRACT: an optional feature provided by a CPAN distribution
+
=pod
@@ -43,7 +42,7 @@ CPAN::Meta::Feature - an optional feature provided by a CPAN distribution
=head1 VERSION
-version 2.110440
+version 2.120630
=head1 DESCRIPTION
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/History.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/History.pm
index ab036907a49..001686e1b70 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Meta/History.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/History.pm
@@ -3,12 +3,12 @@ use 5.006;
use strict;
use warnings;
package CPAN::Meta::History;
-BEGIN {
- $CPAN::Meta::History::VERSION = '2.110440';
-}
-# ABSTRACT: history of CPAN Meta Spec changes
+our $VERSION = '2.120630'; # VERSION
+
1;
+# ABSTRACT: history of CPAN Meta Spec changes
+
__END__
@@ -20,7 +20,7 @@ CPAN::Meta::History - history of CPAN Meta Spec changes
=head1 VERSION
-version 2.110440
+version 2.120630
=head1 DESCRIPTION
@@ -242,7 +242,7 @@ Added 'resources' field with subkeys 'homepage', 'license', and
=item *
-Added 'optional_features' field as an alterate under 'recommends'.
+Added 'optional_features' field as an alternate under 'recommends'.
Includes 'description', 'requires', 'build_requires', 'conflicts',
'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm
index 4fc20939abd..640a299a01d 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm
@@ -2,15 +2,12 @@ use 5.006;
use strict;
use warnings;
package CPAN::Meta::Prereqs;
-BEGIN {
- $CPAN::Meta::Prereqs::VERSION = '2.110440';
-}
-# ABSTRACT: a set of distribution prerequisites by phase and type
+our $VERSION = '2.120630'; # VERSION
use Carp qw(confess);
use Scalar::Util qw(blessed);
-use Version::Requirements 0.101020; # finalize
+use CPAN::Meta::Requirements;
sub __legal_phases { qw(configure build test runtime develop) }
@@ -38,7 +35,7 @@ sub new {
next TYPE unless keys %$spec;
- $guts{prereqs}{$phase}{$type} = Version::Requirements->from_string_hash(
+ $guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash(
$spec
);
}
@@ -62,7 +59,7 @@ sub requirements_for {
confess "requested requirements for unknown type: $type";
}
- my $req = ($self->{prereqs}{$phase}{$type} ||= Version::Requirements->new);
+ my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new);
$req->finalize if $self->is_finalized;
@@ -81,7 +78,7 @@ sub with_merged_prereqs {
for my $phase ($self->__legal_phases) {
for my $type ($self->__legal_types) {
- my $req = Version::Requirements->new;
+ my $req = CPAN::Meta::Requirements->new;
for my $prereq (@prereq_objs) {
my $this_req = $prereq->requirements_for($phase, $type);
@@ -140,6 +137,8 @@ sub clone {
1;
+# ABSTRACT: a set of distribution prerequisites by phase and type
+
=pod
@@ -150,7 +149,7 @@ CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type
=head1 VERSION
-version 2.110440
+version 2.120630
=head1 DESCRIPTION
@@ -190,10 +189,10 @@ dumping the whole set into a structure or string.
my $requirements = $prereqs->requirements_for( $phase, $type );
-This method returns a L<Version::Requirements> object for the given phase/type
-combination. If no prerequisites are registered for that combination, a new
-Version::Requirements object will be returned, and it may be added to as
-needed.
+This method returns a L<CPAN::Meta::Requirements> object for the given
+phase/type combination. If no prerequisites are registered for that
+combination, a new CPAN::Meta::Requirements object will be returned, and it may
+be added to as needed.
If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
be raised.
@@ -216,7 +215,7 @@ will not alter them.
This method returns a hashref containing structures suitable for dumping into a
distmeta data structure. It is made up of hashes and strings, only; there will
-be no Prereqs, Version::Requirements, or C<version> objects inside it.
+be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
=head2 is_finalized
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/Requirements.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/Requirements.pm
new file mode 100644
index 00000000000..483a8448a5b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/Requirements.pm
@@ -0,0 +1,680 @@
+use strict;
+use warnings;
+package CPAN::Meta::Requirements;
+our $VERSION = '2.120630'; # VERSION
+# ABSTRACT: a set of version requirements for a CPAN dist
+
+
+use Carp ();
+use Scalar::Util ();
+use version 0.77 (); # the ->parse method
+
+
+my @valid_options = qw( bad_version_hook );
+
+sub new {
+ my ($class, $options) = @_;
+ $options ||= {};
+ Carp::croak "Argument to $class\->new() must be a hash reference"
+ unless ref $options eq 'HASH';
+ my %self = map {; $_ => $options->{$_}} @valid_options;
+
+ return bless \%self => $class;
+}
+
+sub _version_object {
+ my ($self, $version) = @_;
+
+ my $vobj;
+
+ eval {
+ $vobj = (! defined $version) ? version->parse(0)
+ : (! Scalar::Util::blessed($version)) ? version->parse($version)
+ : $version;
+ };
+
+ if ( my $err = $@ ) {
+ my $hook = $self->{bad_version_hook};
+ $vobj = eval { $hook->($version) }
+ if ref $hook eq 'CODE';
+ unless (Scalar::Util::blessed($vobj) && $vobj->isa("version")) {
+ $err =~ s{ at .* line \d+.*$}{};
+ die "Can't convert '$version': $err";
+ }
+ }
+
+ # ensure no leading '.'
+ if ( $vobj =~ m{\A\.} ) {
+ $vobj = version->parse("0$vobj");
+ }
+
+ # ensure normal v-string form
+ if ( $vobj->is_qv ) {
+ $vobj = version->parse($vobj->normal);
+ }
+
+ return $vobj;
+}
+
+
+BEGIN {
+ for my $type (qw(minimum maximum exclusion exact_version)) {
+ my $method = "with_$type";
+ my $to_add = $type eq 'exact_version' ? $type : "add_$type";
+
+ my $code = sub {
+ my ($self, $name, $version) = @_;
+
+ $version = $self->_version_object( $version );
+
+ $self->__modify_entry_for($name, $method, $version);
+
+ return $self;
+ };
+
+ no strict 'refs';
+ *$to_add = $code;
+ }
+}
+
+
+sub add_requirements {
+ my ($self, $req) = @_;
+
+ for my $module ($req->required_modules) {
+ my $modifiers = $req->__entry_for($module)->as_modifiers;
+ for my $modifier (@$modifiers) {
+ my ($method, @args) = @$modifier;
+ $self->$method($module => @args);
+ };
+ }
+
+ return $self;
+}
+
+
+sub accepts_module {
+ my ($self, $module, $version) = @_;
+
+ $version = $self->_version_object( $version );
+
+ return 1 unless my $range = $self->__entry_for($module);
+ return $range->_accepts($version);
+}
+
+
+sub clear_requirement {
+ my ($self, $module) = @_;
+
+ return $self unless $self->__entry_for($module);
+
+ Carp::confess("can't clear requirements on finalized requirements")
+ if $self->is_finalized;
+
+ delete $self->{requirements}{ $module };
+
+ return $self;
+}
+
+
+sub required_modules { keys %{ $_[0]{requirements} } }
+
+
+sub clone {
+ my ($self) = @_;
+ my $new = (ref $self)->new;
+
+ return $new->add_requirements($self);
+}
+
+sub __entry_for { $_[0]{requirements}{ $_[1] } }
+
+sub __modify_entry_for {
+ my ($self, $name, $method, $version) = @_;
+
+ my $fin = $self->is_finalized;
+ my $old = $self->__entry_for($name);
+
+ Carp::confess("can't add new requirements to finalized requirements")
+ if $fin and not $old;
+
+ my $new = ($old || 'CPAN::Meta::Requirements::_Range::Range')
+ ->$method($version);
+
+ Carp::confess("can't modify finalized requirements")
+ if $fin and $old->as_string ne $new->as_string;
+
+ $self->{requirements}{ $name } = $new;
+}
+
+
+sub is_simple {
+ my ($self) = @_;
+ for my $module ($self->required_modules) {
+ # XXX: This is a complete hack, but also entirely correct.
+ return if $self->__entry_for($module)->as_string =~ /\s/;
+ }
+
+ return 1;
+}
+
+
+sub is_finalized { $_[0]{finalized} }
+
+
+sub finalize { $_[0]{finalized} = 1 }
+
+
+sub as_string_hash {
+ my ($self) = @_;
+
+ my %hash = map {; $_ => $self->{requirements}{$_}->as_string }
+ $self->required_modules;
+
+ return \%hash;
+}
+
+
+my %methods_for_op = (
+ '==' => [ qw(exact_version) ],
+ '!=' => [ qw(add_exclusion) ],
+ '>=' => [ qw(add_minimum) ],
+ '<=' => [ qw(add_maximum) ],
+ '>' => [ qw(add_minimum add_exclusion) ],
+ '<' => [ qw(add_maximum add_exclusion) ],
+);
+
+sub add_string_requirement {
+ my ($self, $module, $req) = @_;
+
+ my @parts = split qr{\s*,\s*}, $req;
+ for my $part (@parts) {
+ my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};
+
+ if (! defined $op) {
+ $self->add_minimum($module => $part);
+ } else {
+ Carp::confess("illegal requirement string: $req")
+ unless my $methods = $methods_for_op{ $op };
+
+ $self->$_($module => $ver) for @$methods;
+ }
+ }
+}
+
+
+sub from_string_hash {
+ my ($class, $hash) = @_;
+
+ my $self = $class->new;
+
+ for my $module (keys %$hash) {
+ $self->add_string_requirement($module, $hash->{ $module });
+ }
+
+ return $self;
+}
+
+##############################################################
+
+{
+ package
+ CPAN::Meta::Requirements::_Range::Exact;
+ sub _new { bless { version => $_[1] } => $_[0] }
+
+ sub _accepts { return $_[0]{version} == $_[1] }
+
+ sub as_string { return "== $_[0]{version}" }
+
+ sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] }
+
+ sub _clone {
+ (ref $_[0])->_new( version->new( $_[0]{version} ) )
+ }
+
+ sub with_exact_version {
+ my ($self, $version) = @_;
+
+ return $self->_clone if $self->_accepts($version);
+
+ Carp::confess("illegal requirements: unequal exact version specified");
+ }
+
+ sub with_minimum {
+ my ($self, $minimum) = @_;
+ return $self->_clone if $self->{version} >= $minimum;
+ Carp::confess("illegal requirements: minimum above exact specification");
+ }
+
+ sub with_maximum {
+ my ($self, $maximum) = @_;
+ return $self->_clone if $self->{version} <= $maximum;
+ Carp::confess("illegal requirements: maximum below exact specification");
+ }
+
+ sub with_exclusion {
+ my ($self, $exclusion) = @_;
+ return $self->_clone unless $exclusion == $self->{version};
+ Carp::confess("illegal requirements: excluded exact specification");
+ }
+}
+
+##############################################################
+
+{
+ package
+ CPAN::Meta::Requirements::_Range::Range;
+
+ sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) }
+
+ sub _clone {
+ return (bless { } => $_[0]) unless ref $_[0];
+
+ my ($s) = @_;
+ my %guts = (
+ (exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()),
+ (exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()),
+
+ (exists $s->{exclusions}
+ ? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ])
+ : ()),
+ );
+
+ bless \%guts => ref($s);
+ }
+
+ sub as_modifiers {
+ my ($self) = @_;
+ my @mods;
+ push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum};
+ push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum};
+ push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []};
+ return \@mods;
+ }
+
+ sub as_string {
+ my ($self) = @_;
+
+ return 0 if ! keys %$self;
+
+ return "$self->{minimum}" if (keys %$self) == 1 and exists $self->{minimum};
+
+ my @exclusions = @{ $self->{exclusions} || [] };
+
+ my @parts;
+
+ for my $pair (
+ [ qw( >= > minimum ) ],
+ [ qw( <= < maximum ) ],
+ ) {
+ my ($op, $e_op, $k) = @$pair;
+ if (exists $self->{$k}) {
+ my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions;
+ if (@new_exclusions == @exclusions) {
+ push @parts, "$op $self->{ $k }";
+ } else {
+ push @parts, "$e_op $self->{ $k }";
+ @exclusions = @new_exclusions;
+ }
+ }
+ }
+
+ push @parts, map {; "!= $_" } @exclusions;
+
+ return join q{, }, @parts;
+ }
+
+ sub with_exact_version {
+ my ($self, $version) = @_;
+ $self = $self->_clone;
+
+ Carp::confess("illegal requirements: exact specification outside of range")
+ unless $self->_accepts($version);
+
+ return CPAN::Meta::Requirements::_Range::Exact->_new($version);
+ }
+
+ sub _simplify {
+ my ($self) = @_;
+
+ if (defined $self->{minimum} and defined $self->{maximum}) {
+ if ($self->{minimum} == $self->{maximum}) {
+ Carp::confess("illegal requirements: excluded all values")
+ if grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] };
+
+ return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum})
+ }
+
+ Carp::confess("illegal requirements: minimum exceeds maximum")
+ if $self->{minimum} > $self->{maximum};
+ }
+
+ # eliminate irrelevant exclusions
+ if ($self->{exclusions}) {
+ my %seen;
+ @{ $self->{exclusions} } = grep {
+ (! defined $self->{minimum} or $_ >= $self->{minimum})
+ and
+ (! defined $self->{maximum} or $_ <= $self->{maximum})
+ and
+ ! $seen{$_}++
+ } @{ $self->{exclusions} };
+ }
+
+ return $self;
+ }
+
+ sub with_minimum {
+ my ($self, $minimum) = @_;
+ $self = $self->_clone;
+
+ if (defined (my $old_min = $self->{minimum})) {
+ $self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0];
+ } else {
+ $self->{minimum} = $minimum;
+ }
+
+ return $self->_simplify;
+ }
+
+ sub with_maximum {
+ my ($self, $maximum) = @_;
+ $self = $self->_clone;
+
+ if (defined (my $old_max = $self->{maximum})) {
+ $self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0];
+ } else {
+ $self->{maximum} = $maximum;
+ }
+
+ return $self->_simplify;
+ }
+
+ sub with_exclusion {
+ my ($self, $exclusion) = @_;
+ $self = $self->_clone;
+
+ push @{ $self->{exclusions} ||= [] }, $exclusion;
+
+ return $self->_simplify;
+ }
+
+ sub _accepts {
+ my ($self, $version) = @_;
+
+ return if defined $self->{minimum} and $version < $self->{minimum};
+ return if defined $self->{maximum} and $version > $self->{maximum};
+ return if defined $self->{exclusions}
+ and grep { $version == $_ } @{ $self->{exclusions} };
+
+ return 1;
+ }
+}
+
+1;
+
+__END__
+=pod
+
+=head1 NAME
+
+CPAN::Meta::Requirements - a set of version requirements for a CPAN dist
+
+=head1 VERSION
+
+version 2.120630
+
+=head1 SYNOPSIS
+
+ use CPAN::Meta::Requirements;
+
+ my $build_requires = CPAN::Meta::Requirements->new;
+
+ $build_requires->add_minimum('Library::Foo' => 1.208);
+
+ $build_requires->add_minimum('Library::Foo' => 2.602);
+
+ $build_requires->add_minimum('Module::Bar' => 'v1.2.3');
+
+ $METAyml->{build_requires} = $build_requires->as_string_hash;
+
+=head1 DESCRIPTION
+
+A CPAN::Meta::Requirements object models a set of version constraints like
+those specified in the F<META.yml> or F<META.json> files in CPAN distributions.
+It can be built up by adding more and more constraints, and it will reduce them
+to the simplest representation.
+
+Logically impossible constraints will be identified immediately by thrown
+exceptions.
+
+=head1 METHODS
+
+=head2 new
+
+ my $req = CPAN::Meta::Requirements->new;
+
+This returns a new CPAN::Meta::Requirements object. It takes an optional
+hash reference argument. The following keys are supported:
+
+=over 4
+
+=item *
+
+<bad_version_hook> -- if provided, when a version cannot be parsed into
+
+a version object, this code reference will be called with the invalid version
+string as an argument. It must return a valid version object.
+
+=back
+
+All other keys are ignored.
+
+=head2 add_minimum
+
+ $req->add_minimum( $module => $version );
+
+This adds a new minimum version requirement. If the new requirement is
+redundant to the existing specification, this has no effect.
+
+Minimum requirements are inclusive. C<$version> is required, along with any
+greater version number.
+
+This method returns the requirements object.
+
+=head2 add_maximum
+
+ $req->add_maximum( $module => $version );
+
+This adds a new maximum version requirement. If the new requirement is
+redundant to the existing specification, this has no effect.
+
+Maximum requirements are inclusive. No version strictly greater than the given
+version is allowed.
+
+This method returns the requirements object.
+
+=head2 add_exclusion
+
+ $req->add_exclusion( $module => $version );
+
+This adds a new excluded version. For example, you might use these three
+method calls:
+
+ $req->add_minimum( $module => '1.00' );
+ $req->add_maximum( $module => '1.82' );
+
+ $req->add_exclusion( $module => '1.75' );
+
+Any version between 1.00 and 1.82 inclusive would be acceptable, except for
+1.75.
+
+This method returns the requirements object.
+
+=head2 exact_version
+
+ $req->exact_version( $module => $version );
+
+This sets the version required for the given module to I<exactly> the given
+version. No other version would be considered acceptable.
+
+This method returns the requirements object.
+
+=head2 add_requirements
+
+ $req->add_requirements( $another_req_object );
+
+This method adds all the requirements in the given CPAN::Meta::Requirements object
+to the requirements object on which it was called. If there are any conflicts,
+an exception is thrown.
+
+This method returns the requirements object.
+
+=head2 accepts_module
+
+ my $bool = $req->accepts_modules($module => $version);
+
+Given an module and version, this method returns true if the version
+specification for the module accepts the provided version. In other words,
+given:
+
+ Module => '>= 1.00, < 2.00'
+
+We will accept 1.00 and 1.75 but not 0.50 or 2.00.
+
+For modules that do not appear in the requirements, this method will return
+true.
+
+=head2 clear_requirement
+
+ $req->clear_requirement( $module );
+
+This removes the requirement for a given module from the object.
+
+This method returns the requirements object.
+
+=head2 required_modules
+
+This method returns a list of all the modules for which requirements have been
+specified.
+
+=head2 clone
+
+ $req->clone;
+
+This method returns a clone of the invocant. The clone and the original object
+can then be changed independent of one another.
+
+=head2 is_simple
+
+This method returns true if and only if all requirements are inclusive minimums
+-- that is, if their string expression is just the version number.
+
+=head2 is_finalized
+
+This method returns true if the requirements have been finalized by having the
+C<finalize> method called on them.
+
+=head2 finalize
+
+This method marks the requirements finalized. Subsequent attempts to change
+the requirements will be fatal, I<if> they would result in a change. If they
+would not alter the requirements, they have no effect.
+
+If a finalized set of requirements is cloned, the cloned requirements are not
+also finalized.
+
+=head2 as_string_hash
+
+This returns a reference to a hash describing the requirements using the
+strings in the F<META.yml> specification.
+
+For example after the following program:
+
+ my $req = CPAN::Meta::Requirements->new;
+
+ $req->add_minimum('CPAN::Meta::Requirements' => 0.102);
+
+ $req->add_minimum('Library::Foo' => 1.208);
+
+ $req->add_maximum('Library::Foo' => 2.602);
+
+ $req->add_minimum('Module::Bar' => 'v1.2.3');
+
+ $req->add_exclusion('Module::Bar' => 'v1.2.8');
+
+ $req->exact_version('Xyzzy' => '6.01');
+
+ my $hashref = $req->as_string_hash;
+
+C<$hashref> would contain:
+
+ {
+ 'CPAN::Meta::Requirements' => '0.102',
+ 'Library::Foo' => '>= 1.208, <= 2.206',
+ 'Module::Bar' => '>= v1.2.3, != v1.2.8',
+ 'Xyzzy' => '== 6.01',
+ }
+
+=head2 add_string_requirement
+
+ $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
+
+This method parses the passed in string and adds the appropriate requirement
+for the given module. It understands version ranges as described in the
+L<CPAN::Meta::Spec/Version Ranges>. For example:
+
+=over 4
+
+=item 1.3
+
+=item >= 1.3
+
+=item <= 1.3
+
+=item == 1.3
+
+=item ! 1.3
+
+=item > 1.3
+
+=item < 1.3
+
+=item >= 1.3, ! 1.5, <= 2.0
+
+A version number without an operator is equivalent to specifying a minimum
+(C<E<gt>=>). Extra whitespace is allowed.
+
+=back
+
+=head2 from_string_hash
+
+ my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
+
+This is an alternate constructor for a CPAN::Meta::Requirements object. It takes
+a hash of module names and version requirement strings and returns a new
+CPAN::Meta::Requirements object.
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden and Ricardo Signes.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm
index 8f94c718cb4..07d32246411 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm
@@ -3,12 +3,12 @@ use 5.006;
use strict;
use warnings;
package CPAN::Meta::Spec;
-BEGIN {
- $CPAN::Meta::Spec::VERSION = '2.110440';
-}
-# ABSTRACT: specification for CPAN distribution metadata
+our $VERSION = '2.120630'; # VERSION
+
1;
+# ABSTRACT: specification for CPAN distribution metadata
+
__END__
@@ -20,7 +20,7 @@ CPAN::Meta::Spec - specification for CPAN distribution metadata
=head1 VERSION
-version 2.110440
+version 2.120630
=head1 SYNOPSIS
@@ -31,6 +31,7 @@ version 2.110440
. "building, testing, and installing Perl modules. "
. "It is meant to ... blah blah blah ...",
version => '0.36',
+ release_status => 'stable',
author => [
'Ken Williams <kwilliams@cpan.org>',
'Module-Build List <module-build@perl.org>', # additional contact
@@ -505,12 +506,12 @@ Valid subkeys are as follows:
=item file
A I<List> of relative paths to files. Paths B<must be> specified with
-unix convetions.
+unix conventions.
=item directory
A I<List> of relative paths to directories. Paths B<must be> specified
-with unix convetions.
+with unix conventions.
[ Note: previous editions of the spec had C<dir> instead of C<directory> ]
@@ -565,13 +566,13 @@ This entry is required and has the same structure as that of the
C<L</prereqs>> key. It provides a list of package requirements
that must be satisfied for the feature to be supported or enabled.
-There is one crucial restriction: the preqreqs of an optional feature
+There is one crucial restriction: the prereqs of an optional feature
B<must not> include C<configure> phase prereqs.
=back
Consumers B<must not> include optional features as prerequisites without
-explict instruction from users (whether via interactive prompting,
+explicit instruction from users (whether via interactive prompting,
a function parameter or a configuration value, etc. ).
If an optional feature is used by a consumer to add additional
@@ -663,8 +664,9 @@ the distribution. The values are Maps with the following valid subkeys:
=item file
-This field is required. The value must contain a relative file path
-from the root of the distribution to the module containing the package.
+This field is required. The value must contain a Unix-style relative
+file path from the root of the distribution to the module containing the
+package.
=item version
@@ -680,12 +682,12 @@ Example:
license => [ 'http://dev.perl.org/licenses/' ],
homepage => 'http://sourceforge.net/projects/module-build',
bugtracker => {
- web => 'http://github.com/dagolden/cpan-meta-spec/issues',
+ web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta',
mailto => 'meta-bugs@example.com',
},
repository => {
- url => 'git://github.com/dagolden/cpan-meta-spec.git',
- web => 'http://github.com/dagolden/cpan-meta-spec',
+ url => 'git://github.com/dagolden/cpan-meta.git',
+ web => 'http://github.com/dagolden/cpan-meta',
type => 'git',
},
x_twitter => 'http://twitter.com/cpan_linked/',
@@ -1027,10 +1029,10 @@ if both are found.
=head2 Extracting Version Numbers from Perl Modules
To get the version number from a Perl module, consumers should use the
-C<< MM->parse_version($file) >> method provided by L<ExtUtils::MakeMaker> or
-the L<Module::Build::ModuleInfo> module provided with L<Module::Build>. For
-example, for the module given by C<$mod>, the version may be retrieved in one
-of the following ways:
+C<< MM->parse_version($file) >> method provided by
+L<ExtUtils::MakeMaker> or L<Module::Metadata>. For example, for the
+module given by C<$mod>, the version may be retrieved in one of the
+following ways:
# via ExtUtils::MakeMaker
my $file = MM->_installed_file_for_module($mod);
@@ -1039,14 +1041,14 @@ of the following ways:
The private C<_installed_file_for_module> method may be replaced with
other methods for locating a module in C<@INC>.
- # via Module::Build
- my $info = Module::Build::ModuleInfo->new_from_module($mod);
+ # via Module::Metadata
+ my $info = Module::Metadata->new_from_module($mod);
my $version = $info->version;
If only a filename is available, the following approach may be used:
# via Module::Build
- my $info = Module::Build::ModuleInfo->new_from_file($file);
+ my $info = Module::Metadata->new_from_file($file);
my $version = $info->version;
=head2 Comparing Version Numbers
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm
index a203621ab8f..1bb53592275 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm
@@ -2,10 +2,7 @@ use 5.006;
use strict;
use warnings;
package CPAN::Meta::Validator;
-BEGIN {
- $CPAN::Meta::Validator::VERSION = '2.110440';
-}
-# ABSTRACT: validate CPAN distribution metadata structures
+our $VERSION = '2.120630'; # VERSION
#--------------------------------------------------------------------------#
@@ -692,7 +689,7 @@ my %v1_licenses = (
'apache' => 'http://apache.org/licenses/LICENSE-2.0',
'artistic' => 'http://opensource.org/licenses/artistic-license.php',
'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php',
- 'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.phpt',
+ 'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php',
'bsd' => 'http://www.opensource.org/licenses/bsd-license.php',
'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
'mit' => 'http://opensource.org/licenses/mit-license.php',
@@ -829,6 +826,8 @@ sub _error {
1;
+# ABSTRACT: validate CPAN distribution metadata structures
+
=pod
@@ -839,7 +838,7 @@ CPAN::Meta::Validator - validate CPAN distribution metadata structures
=head1 VERSION
-version 2.110440
+version 2.120630
=head1 SYNOPSIS
@@ -881,87 +880,143 @@ is valid.
Returns a list of errors seen during validation.
-=begin internals
+=begin :internals
=head2 Check Methods
=over
-=item * check_map($spec,$data)
+=item *
+
+check_map($spec,$data)
Checks whether a map (or hash) part of the data structure conforms to the
appropriate specification definition.
-=item * check_list($spec,$data)
+
+=item *
+
+check_list($spec,$data)
Checks whether a list (or array) part of the data structure conforms to
the appropriate specification definition.
-=item * check_lazylist($spec,$data)
+
+=item *
+
+check_lazylist($spec,$data)
Checks whether a list conforms, but converts strings to a single-element list
+
=back
=head2 Validator Methods
=over
-=item * header($self,$key,$value)
+=item *
+
+header($self,$key,$value)
Validates that the header is valid.
-Note: No longer used as we now read the data structure, not the file.=item * url($self,$key,$value)
+Note: No longer used as we now read the data structure, not the file.
+
+=item *
+
+url($self,$key,$value)
Validates that a given value is in an acceptable URL format
-=item * urlspec($self,$key,$value)
+
+=item *
+
+urlspec($self,$key,$value)
Validates that the URL to a META specification is a known one.
-=item * string_or_undef($self,$key,$value)
+
+=item *
+
+string_or_undef($self,$key,$value)
Validates that the value is either a string or an undef value. Bit of a
catchall function for parts of the data structure that are completely user
defined.
-=item * string($self,$key,$value)
+
+=item *
+
+string($self,$key,$value)
Validates that a string exists for the given key.
-=item * file($self,$key,$value)
+
+=item *
+
+file($self,$key,$value)
Validate that a file is passed for the given key. This may be made more
thorough in the future. For now it acts like \&string.
-=item * exversion($self,$key,$value)
+
+=item *
+
+exversion($self,$key,$value)
Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
-=item * version($self,$key,$value)
+
+=item *
+
+version($self,$key,$value)
Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
are both valid. A leading 'v' like 'v1.2.3' is also valid.
-=item * boolean($self,$key,$value)
+
+=item *
+
+boolean($self,$key,$value)
Validates for a boolean value. Currently these values are '1', '0', 'true',
'false', however the latter 2 may be removed.
-=item * license($self,$key,$value)
+
+=item *
+
+license($self,$key,$value)
Validates that a value is given for the license. Returns 1 if an known license
type, or 2 if a value is given but the license type is not a recommended one.
-=item * custom_1($self,$key,$value)
+
+=item *
+
+custom_1($self,$key,$value)
Validates that the given key is in CamelCase, to indicate a user defined
keyword and only has characters in the class [-_a-zA-Z]. In version 1.X
of the spec, this was only explicitly stated for 'resources'.
-=item * custom_2($self,$key,$value)
+
+=item *
+
+custom_2($self,$key,$value)
Validates that the given key begins with 'x_' or 'X_', to indicate a user
defined keyword and only has characters in the class [-_a-zA-Z]
-=item * identifier($self,$key,$value)
+
+=item *
+
+identifier($self,$key,$value)
Validates that key is in an acceptable format for the META specification,
for an identifier, i.e. any that matches the regular expression
qr/[a-z][a-z_]/i.
-=item * module($self,$key,$value)
+
+=item *
+
+module($self,$key,$value)
Validates that a given key is in an acceptable module name format, e.g.
'Test::CPAN::Meta::Version'.
+
=back
-=end internals
+=end :internals
+
+=for Pod::Coverage anything boolean check_lazylist check_list custom_1 custom_2 exversion file
+identifier license module phase relation release_status string string_or_undef
+url urlspec version header check_map
=head1 BUGS
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm
index 2e94a180840..ba8a702f74d 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm
@@ -1,6 +1,6 @@
package CPAN::Meta::YAML;
-BEGIN {
- $CPAN::Meta::YAML::VERSION = '0.003';
+{
+ $CPAN::Meta::YAML::VERSION = '0.007';
}
use strict;
@@ -459,7 +459,7 @@ sub _write_scalar {
$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
return qq|"$string"|;
}
- if ( $string =~ /(?:^\W|\s)/ or $QUOTE{$string} ) {
+ if ( $string =~ /(?:^\W|\s|:\z)/ or $QUOTE{$string} ) {
return "'$string'";
}
return $string;
@@ -610,12 +610,13 @@ sub LoadFile {
# Use Scalar::Util if possible, otherwise emulate it
BEGIN {
+ local $@;
eval {
require Scalar::Util;
- *refaddr = *Scalar::Util::refaddr;
};
- eval <<'END_PERL' if $@;
-# Failed to load Scalar::Util
+ if ( $@ or $Scalar::Util::VERSION < 1.18 ) {
+ eval <<'END_PERL' if $@;
+# Scalar::Util failed to load or too old
sub refaddr {
my $pkg = ref($_[0]) or return undef;
if ( !! UNIVERSAL::can($_[0], 'can') ) {
@@ -629,7 +630,9 @@ sub refaddr {
$i;
}
END_PERL
-
+ } else {
+ *refaddr = *Scalar::Util::refaddr;
+ }
}
1;
@@ -644,26 +647,26 @@ CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
=head1 VERSION
-version 0.003
+version 0.007
=head1 SYNOPSIS
use CPAN::Meta::YAML;
- # methods for files
- $yaml = CPAN::Meta::YAML->read('META.yml');
- $yaml->write('MYMETA.yml');
-
- # methods for strings
- $yaml_text = $yaml->write_string;
- $yaml = CPAN::Meta::YAML->read_string($yaml_text);
+ # reading a META file
+ open $fh, "<:utf8", "META.yml";
+ $yaml_text = do { local $/; <$fh> };
+ $yaml = CPAN::Meta::YAML->read_string($yaml_text)
+ or die CPAN::Meta::YAML->errstr;
# finding the metadata
- my $meta = $yaml->[0];
+ $meta = $yaml->[0];
- # handling errors
- $yaml->write($file)
+ # writing a META file
+ $yaml_text = $yaml->write_string
or die CPAN::Meta::YAML->errstr;
+ open $fh, ">:utf8", "META.yml";
+ print $fh $yaml_text;
=head1 DESCRIPTION
@@ -671,6 +674,10 @@ This module implements a subset of the YAML specification for use in reading
and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>. It should
not be used for any other general YAML parsing or generation task.
+NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded. Users are
+responsible for proper encoding and decoding. In particular, the C<read> and
+C<write> methods do B<not> support UTF-8 and should not be used.
+
=head1 SUPPORT
This module is currently derived from L<YAML::Tiny> by Adam Kennedy. If
@@ -682,6 +689,25 @@ L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=YAML-Tiny>
L<YAML::Tiny>, L<YAML>, L<YAML::XS>
+=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders
+
+=head1 SUPPORT
+
+=head2 Bugs / Feature Requests
+
+Please report any bugs or feature requests through the issue tracker
+at L<http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta-YAML>.
+You will be notified automatically of any progress on your issue.
+
+=head2 Source Code
+
+This is open source software. The code repository is available for
+public review and contribution under the terms of the license.
+
+L<https://github.com/dagolden/cpan-meta-yaml>
+
+ git clone https://github.com/dagolden/cpan-meta-yaml.git
+
=head1 AUTHORS
=over 4
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
index 3582b0acb4c..daafc1dbaf1 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
@@ -1,5 +1,37 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
+=head1 NAME
+
+CPAN::Mirrors - Get CPAN miror information and select a fast one
+
+=head1 SYNOPSIS
+
+ use CPAN::Mirrors;
+
+ my $mirrors = CPAN::Mirrors->new;
+ $mirrors->parse_from_file( $mirrored_by_file );
+
+ my $seen = {};
+
+ my $best_continent = $mirrors->find_best_continents( { seen => $seen } );
+ my @mirrors = $mirrors->get_mirrors_by_continents( $best_continent );
+
+ my $callback = sub {
+ my( $m ) = @_;
+ printf "%s = %s\n", $m->hostname, $m->rtt
+ };
+ $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback );
+
+ @mirrors = sort { $a->rtt <=> $b->rtt } @mirrors;
+
+ print "Best mirrors are ", map( { $_->rtt } @mirrors[0..3] ), "\n";
+
+=head1 DESCRIPTION
+
+=over
+
+=cut
+
package CPAN::Mirrors;
use strict;
use vars qw($VERSION $urllist $silent);
@@ -10,31 +42,55 @@ use FileHandle;
use Fcntl ":flock";
use Net::Ping ();
+=item new( LOCAL_FILE_NAME )
+
+=cut
+
sub new {
my ($class, $file) = @_;
- my $self = bless {
- mirrors => [],
- geography => {},
+ my $self = bless {
+ mirrors => [],
+ geography => {},
}, $class;
+ if( defined $file ) {
+ $self->parse_mirrored_by( $file );
+ }
+
+ return $self
+}
+
+sub parse_mirrored_by {
+ my ($self, $file) = @_;
my $handle = FileHandle->new;
- $handle->open($file)
+ $handle->open($file)
or croak "Couldn't open $file: $!";
flock $handle, LOCK_SH;
$self->_parse($file,$handle);
flock $handle, LOCK_UN;
$handle->close;
+}
- # populate continents & countries
+=item continents()
- return $self
-}
+Return a list of continents based on those defined in F<MIRRORED.BY>.
+
+=cut
sub continents {
my ($self) = @_;
return keys %{$self->{geography}};
}
+=item countries( [CONTINENTS] )
+
+Return a list of countries based on those defined in F<MIRRORED.BY>.
+It only returns countries for the continents you specify (as defined
+in C<continents>). If you don't specify any continents, it returns all
+of the countries listed in F<MIRRORED.BY>.
+
+=cut
+
sub countries {
my ($self, @continents) = @_;
@continents = $self->continents unless @continents;
@@ -45,6 +101,15 @@ sub countries {
return @countries;
}
+=item mirrors( [COUNTRIES] )
+
+Return a list of mirrors based on those defined in F<MIRRORED.BY>.
+It only returns mirrors for the countries you specify (as defined
+in C<countries>). If you don't specify any countries, it returns all
+of the mirrors listed in F<MIRRORED.BY>.
+
+=cut
+
sub mirrors {
my ($self, @countries) = @_;
return @{$self->{mirrors}} unless @countries;
@@ -56,118 +121,300 @@ sub mirrors {
return @found;
}
+=item get_mirrors_by_countries( [COUNTRIES] )
+
+A more sensible synonym for mirrors.
+
+=cut
+
+sub get_mirrors_by_countries { &mirrors }
+
+=item get_mirrors_by_continents( [CONTINENTS] )
+
+Return a list of mirrors for all of continents you specify. If you don't
+specify any continents, it returns all of the mirrors.
+
+=cut
+
+sub get_mirrors_by_continents {
+ my ($self, $continents ) = @_;
+
+ $self->mirrors( $self->get_countries_by_continents( @$continents ) );
+ }
+
+=item get_countries_by_continents( [CONTINENTS] )
+
+A more sensible synonym for countries.
+
+=cut
+sub get_countries_by_continents { &countries }
+
+=item best_mirrors
+
+C<best_mirrors> checks for the best mirrors based on the list of
+continents you pass, or, without that, all continents, as defined
+by C<CPAN::Mirrored::By>. It pings each mirror, up to the value of
+C<how_many>. In list context, it returns up to C<how_many> mirror.
+In scalar context, it returns the single best mirror.
+
+Arguments
+
+ how_many - the number of mirrors to return. Default: 1
+ callback - a callback for find_best_continents
+ verbose - true or false on all the whining and moaning. Default: false
+ continents - an array ref of the continents to check
+
+If you don't specify the continents, C<best_mirrors> calls
+C<find_best_continents> to get the list of continents to check.
+
+=cut
+
sub best_mirrors {
my ($self, %args) = @_;
- my $how_many = $args{how_many} || 1;
- my $callback = $args{callback};
- my $verbose = $args{verbose};
- my $conts = $args{continents} || [];
- $conts = [$conts] unless ref $conts;
+ my $how_many = $args{how_many} || 1;
+ my $callback = $args{callback};
+ my $verbose = defined $args{verbose} ? $args{verbose} : 0;
+ my $continents = $args{continents} || [];
+ $continents = [$continents] unless ref $continents;
# Old Net::Ping did not do timings at all
return "http://www.cpan.org/" unless Net::Ping->VERSION gt '2.13';
my $seen = {};
- if ( ! @$conts ) {
+ if ( ! @$continents ) {
print "Searching for the best continent ...\n" if $verbose;
- my @best = $self->_find_best_continent($seen, $verbose, $callback);
+ my @best_continents = $self->find_best_continents(
+ seen => $seen,
+ verbose => $verbose,
+ callback => $callback,
+ );
# Only add enough continents to find enough mirrors
my $count = 0;
- for my $c ( @best ) {
- push @$conts, $c;
- $count += $self->mirrors( $self->countries($c) );
+ for my $continent ( @best_continents ) {
+ push @$continents, $continent;
+ $count += $self->mirrors( $self->countries($continent) );
last if $count >= $how_many;
}
}
- print "Scanning " . join(", ", @$conts) . " ...\n" if $verbose;
+ print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose;
+
+ my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] );
+
+ my $timings = $self->get_mirrors_timings( $trial_mirrors, $seen, $callback );
+ return [] unless @$timings;
+
+ $how_many = @$timings if $how_many > @$timings;
+
+ return wantarray ? @{$timings}[0 .. $how_many-1] : $timings->[0];
+}
+
+=item get_n_random_mirrors_by_continents( N, [CONTINENTS]
+
+Returns up to N random mirrors for the specified continents. Specify the
+continents as an array reference.
+
+=cut
+
+sub get_n_random_mirrors_by_continents {
+ my( $self, $n, $continents ) = @_;
+ $n ||= 3;
+ $continents = [ $continents ] unless ref $continents;
- my @timings;
- my @long_list = $self->mirrors($self->countries(@$conts));
- my $long_list_size = ( $how_many > 10 ? $how_many : 10 );
- if ( @long_list > $long_list_size ) {
- @long_list = map {$_->[0]}
- sort {$a->[1] <=> $b->[1]}
- map {[$_, rand]} @long_list;
- splice @long_list, $long_list_size; # truncate
+ if ( $n <= 0 ) {
+ return wantarray ? () : [];
}
- for my $m ( @long_list ) {
- next unless $m->http;
- my $hostname = $m->hostname;
- if ( $seen->{$hostname} ) {
- push @timings, $seen->{$hostname}
- if defined $seen->{$hostname}[1];
+ my @long_list = $self->get_mirrors_by_continents( $continents );
+
+ if ( $n eq '*' or $n > @long_list ) {
+ return wantarray ? @long_list : \@long_list;
+ }
+
+ @long_list = map {$_->[0]}
+ sort {$a->[1] <=> $b->[1]}
+ map {[$_, rand]} @long_list;
+
+ splice @long_list, $n; # truncate
+
+ \@long_list;
+}
+
+=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK );
+
+Pings the listed mirrors and returns a list of mirrors sorted
+in ascending ping times.
+
+=cut
+
+sub get_mirrors_timings {
+ my( $self, $mirror_list, $seen, $callback ) = @_;
+
+ $seen = {} unless defined $seen;
+ croak "The mirror list argument must be an array reference"
+ unless ref $mirror_list eq ref [];
+ croak "The seen argument must be a hash reference"
+ unless ref $seen eq ref {};
+ croak "callback must be a subroutine"
+ if( defined $callback and ref $callback ne ref sub {} );
+
+ my $timings = [];
+ for my $m ( @$mirror_list ) {
+ $seen->{$m->hostname} = $m;
+ next unless eval{ $m->http };
+
+ if( $self->_try_a_ping( $seen, $m, ) ) {
+ my $ping = $m->ping;
+ next unless defined $ping;
+ push @$timings, $m;
+ $callback->( $m ) if $callback;
}
else {
- my $ping = $m->ping;
- next unless defined $ping;
- push @timings, [$m, $ping];
- $callback->($m,$ping) if $callback;
+ push @$timings, $seen->{$m->hostname}
+ if defined $seen->{$m->hostname}->rtt;
}
}
- return unless @timings;
-
- $how_many = @timings if $how_many > @timings;
- my @best =
- map { $_->[0] }
- sort { $a->[1] <=> $b->[1] } @timings;
- return wantarray ? @best[0 .. $how_many-1] : $best[0];
+ my @best = sort {
+ if( defined $a->rtt and defined $b->rtt ) {
+ $a->rtt <=> $b->rtt
+ }
+ elsif( defined $a->rtt and ! defined $b->rtt ) {
+ return -1;
+ }
+ elsif( ! defined $a->rtt and defined $b->rtt ) {
+ return 1;
+ }
+ elsif( ! defined $a->rtt and ! defined $b->rtt ) {
+ return 0;
+ }
+
+ } @$timings;
+
+ return wantarray ? @best : \@best;
}
-sub _find_best_continent {
- my ($self, $seen, $verbose, $callback) = @_;
+=item find_best_continents( HASH_REF );
+
+C<find_best_continents> goes through each continent and pings C<N> random
+mirrors on that continent. It then orders the continents by ascending
+median ping time. In list context, it returns the ordered list of
+continent. In scalar context, it returns the same list as an anonymous
+array.
+
+Arguments:
+
+ n - the number of hosts to ping for each continent. Default: 3
+ seen - a hashref of cached hostname ping times
+ verbose - true or false for noisy or quiet. Default: false
+ callback - a subroutine to run after each ping.
+ ping_cache_limit - how long, in seconds, to reuse previous ping times.
+ Default: 1 day
+
+The C<seen> hash has hostnames as keys and anonymous arrays as values. The
+anonymous array is a triplet of a C<CPAN::Mirrored::By> object, a ping
+time, and the epoch time for the measurement.
+
+The callback subroutine gets the C<CPAN::Mirrored::By> object, the ping
+time, and measurement time (the same things in the C<seen> hashref) as arguments.
+C<find_best_continents> doesn't care what the callback does and ignores the return
+value.
- my %median;
+=cut
+
+sub find_best_continents {
+ my ($self, %args) = @_;
+
+ $args{n} ||= 3;
+ $args{verbose} = 0 unless defined $args{verbose};
+ $args{seen} = {} unless defined $args{seen};
+ croak "The seen argument must be a hash reference"
+ unless ref $args{seen} eq ref {};
+ $args{ping_cache_limit} = 24 * 60 * 60
+ unless defined $args{ping_cache_time};
+ croak "callback must be a subroutine"
+ if( defined $args{callback} and ref $args{callback} ne ref sub {} );
+
+ my %medians;
CONT: for my $c ( $self->continents ) {
+ print "Testing $c\n" if $args{verbose};
my @mirrors = $self->mirrors( $self->countries($c) );
+
next CONT unless @mirrors;
- my $sample = 3;
- my $n = (@mirrors < $sample) ? @mirrors : $sample;
+ my $n = (@mirrors < $args{n}) ? @mirrors : $args{n};
+
my @tests;
- RANDOM: while ( @mirrors && @tests < $n ) {
+ my $tries = 0;
+ RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) {
my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
- my $ping = $m->ping;
- $callback->($m,$ping) if $callback;
- # record undef so we don't try again
- $seen->{$m->hostname} = [$m, $ping];
- next RANDOM unless defined $ping;
- push @tests, $ping;
- }
- next CONT unless @tests;
- @tests = sort { $a <=> $b } @tests;
- if ( @tests == 1 ) {
- $median{$c} = $tests[0];
- }
- elsif ( @tests % 2 ) {
- $median{$c} = $tests[ int(@tests / 2) ];
- }
- else {
- my $mid_high = int(@tests/2);
- $median{$c} = ($tests[$mid_high-1] + $tests[$mid_high])/2;
+ if( $self->_try_a_ping( $args{seen}, $m, $args{ping_cache_limit} ) ) {
+ $self->get_mirrors_timings( [ $m ], @args{qw(seen callback)} );
+ next RANDOM unless defined $args{seen}{$m->hostname}->rtt;
+ }
+ printf "\t%s -> %0.2f ms\n",
+ $m->hostname,
+ join ' ', 1000 * $args{seen}{$m->hostname}->rtt
+ if $args{verbose};
+
+ push @tests, $args{seen}{$m->hostname}->rtt;
}
+
+ my $median = $self->_get_median_ping_time( \@tests, $args{verbose} );
+ $medians{$c} = $median if defined $median;
}
- my @best_cont = sort { $median{$a} <=> $median{$b} } keys %median ;
+ my @best_cont = sort { $medians{$a} <=> $medians{$b} } keys %medians;
- if ( $verbose ) {
+ if ( $args{verbose} ) {
print "Median result by continent:\n";
for my $c ( @best_cont ) {
- printf( " %d ms %s\n", int($median{$c}*1000+.5), $c );
+ printf( " %4d ms %s\n", int($medians{$c}*1000+.5), $c );
}
}
return wantarray ? @best_cont : $best_cont[0];
}
+# retry if
+sub _try_a_ping {
+ my ($self, $seen, $mirror, $ping_cache_limit ) = @_;
+
+ ( ! exists $seen->{$mirror->hostname} )
+ or
+ (
+ ! defined $seen->{$mirror->hostname}->rtt
+ or
+ time - $seen->{$mirror->hostname}->rtt > $ping_cache_limit
+ )
+}
+
+sub _get_median_ping_time {
+ my ($self, $tests, $verbose ) = @_;
+
+ my @sorted = sort { $a <=> $b } @$tests;
+
+ my $median = do {
+ if ( @sorted == 0 ) { undef }
+ elsif ( @sorted == 1 ) { $sorted[0] }
+ elsif ( @sorted % 2 ) { $sorted[ int(@sorted / 2) ] }
+ else {
+ my $mid_high = int(@sorted/2);
+ ($sorted[$mid_high-1] + $sorted[$mid_high])/2;
+ }
+ };
+
+ printf "\t-->median time: %0.2f ms\n", $median * 1000 if $verbose;
+
+ return $median;
+}
+
# Adapted from Parse::CPAN::MirroredBy by Adam Kennedy
sub _parse {
my ($self, $file, $handle) = @_;
my $output = $self->{mirrors};
- my $geo = $self->{geography};
+ my $geo = $self->{geography};
local $/ = "\012";
my $line = 0;
@@ -193,7 +440,7 @@ sub _parse {
$mirror ||= {};
if ( $prop eq 'dst_location' ) {
my (@location,$continent,$country);
- @location = (split /\s*,\s*/, $value)
+ @location = (split /\s*,\s*/, $value)
and ($continent, $country) = @location[-1,-2];
$continent =~ s/\s\(.*//;
$continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude
@@ -244,35 +491,61 @@ sub new {
$arg ||= {};
bless $arg, $self;
}
-sub hostname { shift->{hostname} }
-sub continent { shift->{continent} }
-sub country { shift->{country} }
-sub http { shift->{http} || '' }
-sub ftp { shift->{ftp} || '' }
-sub rsync { shift->{rsync} || '' }
-
-sub url {
+sub hostname { shift->{hostname} }
+sub continent { shift->{continent} }
+sub country { shift->{country} }
+sub http { shift->{http} || '' }
+sub ftp { shift->{ftp} || '' }
+sub rsync { shift->{rsync} || '' }
+sub rtt { shift->{rtt} }
+sub ping_time { shift->{ping_time} }
+
+sub url {
my $self = shift;
return $self->{http} || $self->{ftp};
}
sub ping {
my $self = shift;
+
my $ping = Net::Ping->new("tcp",1);
my ($proto) = $self->url =~ m{^([^:]+)};
my $port = $proto eq 'http' ? 80 : 21;
return unless $port;
- if ( $ping->can('port_number') ) {
- $ping->port_number($port);
+
+ if ( $ping->can('port_number') ) {
+ $ping->port_number($port);
}
else {
$ping->{'port_num'} = $port;
}
+
$ping->hires(1) if $ping->can('hires');
my ($alive,$rtt) = $ping->ping($self->hostname);
- return $alive ? $rtt : undef;
+
+ $self->{rtt} = $alive ? $rtt : undef;
+ $self->{ping_time} = time;
+
+ $self->rtt;
}
1;
+=back
+
+=head1 AUTHOR
+
+Andreas Koenig C<< <andk@cpan.org> >>, David Golden C<< <dagolden@cpan.org> >>,
+brian d foy C<< <bdfoy@cpan.org> >>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Shell.pm b/Master/tlpkg/tlperl/lib/CPAN/Shell.pm
index 9effb0d2e70..21441df653f 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Shell.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Shell.pm
@@ -653,7 +653,7 @@ sub mkmyconfig {
"CPAN::MyConfig already exists as $configpm.\n" .
"Running configuration again...\n"
);
- require CPAN::FirstTime;
+ require CPAN::FirstTime;
CPAN::FirstTime::init($configpm);
}
else {
@@ -1221,6 +1221,7 @@ sub autobundle {
$fh->close;
$CPAN::Frontend->myprint("\nWrote bundle file
$to\n\n");
+ return $to;
}
#-> sub CPAN::Shell::expandany ;
@@ -1684,7 +1685,7 @@ sub rematein {
if ($meth =~ /^($needs_recursion_protection)$/) {
# it would be silly to check for recursion for look or dump
# (we are in CPAN::Shell::rematein)
- CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
+ CPAN->debug("Testing against recursion") if $CPAN::DEBUG;
eval { $obj->color_cmd_tmps(0,1); };
if ($@) {
if (ref $@
@@ -1847,7 +1848,7 @@ sub recent {
my($self) = @_;
if ($CPAN::META->has_inst("XML::LibXML")) {
my $url = $CPAN::Defaultrecent;
- $CPAN::Frontend->myprint("Going to fetch '$url'\n");
+ $CPAN::Frontend->myprint("Fetching '$url'\n");
unless ($CPAN::META->has_usable("LWP")) {
$CPAN::Frontend->mydie("LWP not installed; cannot continue");
}
@@ -1935,7 +1936,7 @@ sub smoke {
my $distros = $self->recent;
DISTRO: for my $distro (@$distros) {
next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
- $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
+ $CPAN::Frontend->myprint(sprintf "Downloading and testing '$distro'\n");
{
my $skip = 0;
local $SIG{INT} = sub { $skip = 1 };