summaryrefslogtreecommitdiff
path: root/cpan
diff options
context:
space:
mode:
authorAndreas Koenig <root@dubravka.in-berlin.de>2019-06-13 19:04:47 +0000
committerKaren Etheridge <ether@cpan.org>2019-06-20 09:19:40 -0700
commit5cf88abdca2d5d3d5c7adb953cb5f971f3c4539a (patch)
tree74c07a135f10172e8b54c0c6a296dee973060596 /cpan
parentd2ece0ba72dfad1ecde95093c98e71b716988eb4 (diff)
downloadperl-5cf88abdca2d5d3d5c7adb953cb5f971f3c4539a.tar.gz
[PATCH] Updates CPAN.pm to ANDK/CPAN-2.27-TRIAL2.tar.gz
2019-06-09 k <andk@cpan.org> * release 2.27-TRIAL2 * bugfix: omit the new POSIX::setsid call and the waitpid with WNOHANG on Windows * bugfix: the signalhandler has to kill the new process group spawned for running the tests * adding the README file that was generated during the release of 2.27-TRIAL 2019-05-31 k <andk@cpan.org> * release 2.27-TRIAL * two new options to protect against accidental downgrades: allow_installing_outdated_dists and allow_installing_module_downgrades * two new options to tune the automatic determination of the nearest peers: urllist_ping_external and urllist_ping_verbose; NOTE: this feature was developed during the Perl Toolchain Summit 2019 in Marlow; thanks to the sponsors: Booking.com, cPanel, MaxMind, FastMail, ZipRecruiter, Cogendo, Elastic, OpenCage Data, Perl Services, Zoopla, Archer Education, OpusVL, Oetiker+Partner, SureVoIP, YEF * reveal the size of PERL5LIB in diagnostic output * new semantics for parameter ftpstats_size: setting to '0' or lower, disables download statistics * bugfix: under certain circumstances, failing dependencies via recommends and suggests could abort a build; this is now fixed * bugfix: protect bundle processing against unavailable bundle files and missing build directories * bugfix: fix broken permissions after untar * bugfix: protect against exceptions from unzip * bugfix: add one level of fork+setsid for testing to prevent that a test can kill the process group that CPAN.pm is running in. Learned from experience with testing VIZDOM/DBD-JDBC-0.71.tar.gz * fix plugins: all early returns from all methods, that are accessible for plugins, now call the post* plugins * new question answered in the FAQ: "How can I switch to sudo instead of local::lib" (thanks to Amos Bird for asking the question on irc) * plenty of new and updated distroprefs documents, among which are some important ones to prevent Module::AutoInstall from switching to CPANPLUS and taking over (and harming) the build
Diffstat (limited to 'cpan')
-rw-r--r--cpan/CPAN/lib/CPAN.pm77
-rw-r--r--cpan/CPAN/lib/CPAN/Bundle.pm15
-rw-r--r--cpan/CPAN/lib/CPAN/Distribution.pm339
-rw-r--r--cpan/CPAN/lib/CPAN/FTP.pm19
-rw-r--r--cpan/CPAN/lib/CPAN/FirstTime.pm77
-rw-r--r--cpan/CPAN/lib/CPAN/HandleConfig.pm10
-rw-r--r--cpan/CPAN/lib/CPAN/Mirrors.pm119
-rw-r--r--cpan/CPAN/scripts/cpan7
8 files changed, 567 insertions, 96 deletions
diff --git a/cpan/CPAN/lib/CPAN.pm b/cpan/CPAN/lib/CPAN.pm
index a25a5fad7b..2d87f47f8b 100644
--- a/cpan/CPAN/lib/CPAN.pm
+++ b/cpan/CPAN/lib/CPAN.pm
@@ -2,7 +2,7 @@
# vim: ts=4 sts=4 sw=4:
use strict;
package CPAN;
-$CPAN::VERSION = '2.26';
+$CPAN::VERSION = '2.27';
$CPAN::VERSION =~ s/_//;
# we need to run chdir all over and we would get at wrong libraries
@@ -1468,11 +1468,12 @@ sub set_perl5lib {
$ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
} else {
my $cnt = keys %{$self->{is_tested}};
- $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ".
- "$cnt build dirs to PERL5LIB; ".
- "for '$for'\n"
+ my $newenv = join $Config::Config{path_sep}, @dirs, @env;
+ $CPAN::Frontend->optprint('perl5lib', sprintf ("Prepending blib/arch and blib/lib of ".
+ "%d build dirs to PERL5LIB, reaching size %d; ".
+ "for '%s'\n", $cnt, length($newenv), $for)
);
- $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
+ $ENV{PERL5LIB} = $newenv;
}
}}
@@ -2144,6 +2145,12 @@ where WORD is any valid config variable or a regular expression.
The following keys in the hash reference $CPAN::Config are
currently defined:
+ allow_installing_module_downgrades
+ allow or disallow installing module downgrades
+ allow_installing_outdated_dists
+ allow or disallow installing modules that are
+ indexed in the cpan index pointing to a distro
+ with a higher distro-version number
applypatch path to external prg
auto_commit commit all changes to config variables to disk
build_cache size of cache for directories to build modules
@@ -2262,6 +2269,10 @@ currently defined:
CPAN::Reporter history)
unzip location of external program unzip
urllist arrayref to nearby CPAN sites (or equivalent locations)
+ urllist_ping_external
+ use external ping command when autoselecting mirrors
+ urllist_ping_verbose
+ increase verbosity when autoselecting mirrors
use_prompt_default set PERL_MM_USE_DEFAULT for configure/make/test/install
use_sqlite use CPAN::SQLite for metadata storage (fast and lean)
username your username if you CPAN server wants one
@@ -2407,6 +2418,43 @@ both modules declared as C<requires> and those declared as
C<build_requires> are treated alike. By setting to C<ask/yes> or
C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
+=head2 Configuration of the allow_installing_* parameters
+
+The C<allow_installing_*> parameters are evaluated during
+the C<make> phase. If set to C<yes>, they allow the testing and the installation of
+the current distro and otherwise have no effect. If set to C<no>, they
+may abort the build (preventing testing and installing), depending on the contents of the
+C<blib/> directory. The C<blib/> directory is the directory that holds
+all the files that would usually be installed in the C<install> phase.
+
+C<allow_installing_outdated_dists> compares the C<blib/> directory with the CPAN index.
+If it finds something there that belongs, according to the index, to a different
+dist, it aborts the current build.
+
+C<allow_installing_module_downgrades> compares the C<blib/> directory
+with already installed modules, actually their version numbers, as
+determined by ExtUtils::MakeMaker or equivalent. If a to-be-installed
+module would downgrade an already installed module, the current build
+is aborted.
+
+An interesting twist occurs when a distroprefs document demands the
+installation of an outdated dist via goto while
+C<allow_installing_outdated_dists> forbids it. Without additional
+provisions, this would let the C<allow_installing_outdated_dists>
+win and the distroprefs lose. So the proper arrangement in such a case
+is to write a second distroprefs document for the distro that C<goto>
+points to and overrule the C<cpanconfig> there. E.g.:
+
+ ---
+ match:
+ distribution: "^MAUKE/Keyword-Simple-0.04.tar.gz"
+ goto: "MAUKE/Keyword-Simple-0.03.tar.gz"
+ ---
+ match:
+ distribution: "^MAUKE/Keyword-Simple-0.03.tar.gz"
+ cpanconfig:
+ allow_installing_outdated_dists: yes
+
=head2 Configuration for individual distributions (I<Distroprefs>)
(B<Note:> This feature has been introduced in CPAN.pm 1.8854)
@@ -3946,6 +3994,25 @@ directory) or exit the CPAN shell, respectively. If you never start up
the CPAN shell, you probably also have to clean up the build directory
yourself.
+=item 19)
+
+How can I switch to sudo instead of local::lib?
+
+The following 5 environment veriables need to be reset to the previous
+values: PATH, PERL5LIB, PERL_LOCAL_LIB_ROOT, PERL_MB_OPT, PERL_MM_OPT;
+and these two CPAN.pm config variables must be reconfigured:
+make_install_make_command and mbuild_install_build_command. The five
+env variables have probably been overwritten in your $HOME/.bashrc or
+some equivalent. You either find them there and delete their traces
+and logout/login or you override them temporarily, depending on your
+exact desire. The two cpanpm config variables can be set with:
+
+ o conf init /install_.*_command/
+
+probably followed by
+
+ o conf commit
+
=back
=head1 COMPATIBILITY
diff --git a/cpan/CPAN/lib/CPAN/Bundle.pm b/cpan/CPAN/lib/CPAN/Bundle.pm
index 9270502914..99c95ac4d6 100644
--- a/cpan/CPAN/lib/CPAN/Bundle.pm
+++ b/cpan/CPAN/lib/CPAN/Bundle.pm
@@ -8,7 +8,7 @@ use CPAN::Module;
use vars qw(
$VERSION
);
-$VERSION = "5.5004";
+$VERSION = "5.5005";
sub look {
my $self = shift;
@@ -87,11 +87,11 @@ sub contains {
# Try to get at it in the cpan directory
$self->debug("no inst_file") if $CPAN::DEBUG;
my $cpan_file;
- $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
+ $CPAN::Frontend->mydie("I don't know a bundle with ID '$id'\n") unless
$cpan_file = $self->cpan_file;
if ($cpan_file eq "N/A") {
- $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
- Maybe stale symlink? Maybe removed during session? Giving up.\n");
+ $CPAN::Frontend->mywarn("Bundle '$id' not found on disk and not on CPAN. Maybe stale symlink? Maybe removed during session?\n");
+ return;
}
my $dist = $CPAN::META->instance('CPAN::Distribution',
$self->cpan_file);
@@ -103,7 +103,12 @@ sub contains {
@me = split /::/, $self->id;
$me[-1] .= ".pm";
$me = File::Spec->catfile(@me);
- $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
+ my $build_dir;
+ unless ($build_dir = $dist->{build_dir}) {
+ $CPAN::Frontend->mywarn("Warning: cannot determine bundle content without a build_dir.\n");
+ return;
+ }
+ $from = $self->find_bundle_file($build_dir,join('/',@me));
$to = File::Spec->catfile($todir,$me);
File::Path::mkpath(File::Basename::dirname($to));
File::Copy::copy($from, $to)
diff --git a/cpan/CPAN/lib/CPAN/Distribution.pm b/cpan/CPAN/lib/CPAN/Distribution.pm
index ea637c865b..3412108539 100644
--- a/cpan/CPAN/lib/CPAN/Distribution.pm
+++ b/cpan/CPAN/lib/CPAN/Distribution.pm
@@ -6,9 +6,12 @@ use Cwd qw(chdir);
use CPAN::Distroprefs;
use CPAN::InfoObj;
use File::Path ();
+use POSIX ":sys_wait_h";
@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
use vars qw($VERSION);
-$VERSION = "2.24";
+$VERSION = "2.27";
+
+my $run_allow_installing_within_test = 1; # boolean; either in test or in install, there is no third option
# no prepare, because prepare is not a command on the shell command line
# TODO: clear instance cache on reload
@@ -377,10 +380,12 @@ sub get {
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
if (my $goto = $self->prefs->{goto}) {
+ $self->post_get();
return $self->goto($goto);
}
if ( defined( my $sc = $self->shortcut_get) ) {
+ $self->post_get();
return $sc;
}
@@ -399,15 +404,22 @@ sub get {
# is already checked in shortcut_get() -- xdg, 2012-04-05
unless ($self->{build_dir} && -d $self->{build_dir}) {
$self->get_file_onto_local_disk;
- return if $CPAN::Signal;
+ if ($CPAN::Signal){
+ $self->post_get();
+ return;
+ }
$self->check_integrity;
- return if $CPAN::Signal;
+ if ($CPAN::Signal){
+ $self->post_get();
+ return;
+ }
(my $packagedir,$local_file) = $self->run_preps_on_packagedir;
# XXX why is this check here? -- xdg, 2012-04-08
if (exists $self->{writemakefile} && ref $self->{writemakefile}
&& $self->{writemakefile}->can("failed") &&
$self->{writemakefile}->failed) {
#
+ $self->post_get();
return;
}
$packagedir ||= $self->{build_dir};
@@ -419,9 +431,13 @@ sub get {
# a $CPAN::Signal check -- xdg, 2012-04-05
if ($CPAN::Signal) {
$self->safe_chdir($sub_wd);
+ $self->post_get();
+ return;
+ }
+ unless ($self->patch){
+ $self->post_get();
return;
}
- return unless $self->patch;
$self->store_persistent_state;
$self->post_get();
@@ -540,9 +556,10 @@ See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
if (@readdir == 1 && -d $readdir[0]) {
$tdir_base = $readdir[0];
$from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
+ my($mode) = (stat $from_dir)[2];
+ chmod $mode | 00755, $from_dir; # JONATHAN/Math-Calculus-TaylorSeries-0.1.tar.gz has 0644
my $dh2;
unless ($dh2 = DirHandle->new($from_dir)) {
- my($mode) = (stat $from_dir)[2];
my $why = sprintf
(
"Couldn't opendir '%s', mode '%o': %s",
@@ -565,10 +582,6 @@ See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
$from_dir = File::Spec->curdir;
@dirents = @readdir;
}
- eval { File::Path::mkpath $builddir; };
- if ($@) {
- $CPAN::Frontend->mydie("Cannot create directory $builddir: $@");
- }
my $packagedir;
my $eexist = ($CPAN::META->has_usable("Errno") && defined &Errno::EEXIST)
? &Errno::EEXIST : undef;
@@ -583,6 +596,8 @@ See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
my $f;
for $f (@dirents) { # is already without "." and ".."
my $from = File::Spec->catfile($from_dir,$f);
+ my($mode) = (stat $from)[2];
+ chmod $mode | 00755, $from if -d $from; # OTTO/Pod-Trial-LinkImg-0.005.tgz
my $to = File::Spec->catfile($packagedir,$f);
unless (File::Copy::move($from,$to)) {
my $err = $!;
@@ -1228,10 +1243,10 @@ sub untar_me {
sub unzip_me {
my($self,$ct) = @_;
$self->{archived} = "zip";
- if ($ct->unzip()) {
+ if (eval { $ct->unzip() }) {
$self->{unwrapped} = CPAN::Distrostatus->new("YES");
} else {
- $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed during unzip");
}
return;
}
@@ -1846,7 +1861,9 @@ sub prepare {
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
- local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # prepare
+ local $ENV{PERL_USE_UNSAFE_INC} =
+ exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
+ ? $ENV{PERL_USE_UNSAFE_INC} : 1; # prepare
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
@@ -2081,11 +2098,13 @@ sub make {
$self->pre_make();
if (exists $self->{cleanup_after_install_done}) {
+ $self->post_make();
return $self->get;
}
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
if (my $goto = $self->prefs->{goto}) {
+ $self->post_make();
return $self->goto($goto);
}
# Emergency brake if they said install Pippi and get newest perl
@@ -2122,19 +2141,24 @@ is part of the perl-%s distribution. To install that, you need to run
));
$self->{make} = CPAN::Distrostatus->new("NO isa perl");
$CPAN::Frontend->mysleep(1);
+ $self->post_make();
return;
}
}
- $self->prepare
- or return;
+ unless ($self->prepare){
+ $self->post_make();
+ return;
+ }
if ( defined( my $sc = $self->shortcut_make) ) {
+ $self->post_make();
return $sc;
}
if ($CPAN::Signal) {
delete $self->{force_update};
+ $self->post_make();
return;
}
@@ -2143,6 +2167,7 @@ is part of the perl-%s distribution. To install that, you need to run
unless (chdir $builddir) {
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
+ $self->post_make();
return;
}
@@ -2152,17 +2177,21 @@ is part of the perl-%s distribution. To install that, you need to run
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
- local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # make
+ local $ENV{PERL_USE_UNSAFE_INC} =
+ exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
+ ? $ENV{PERL_USE_UNSAFE_INC} : 1; # make
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
if ($CPAN::Signal) {
delete $self->{force_update};
+ $self->post_make();
return;
}
if ($^O eq 'MacOS') {
Mac::BuildTools::make($self);
+ $self->post_make();
return;
}
@@ -2173,16 +2202,23 @@ is part of the perl-%s distribution. To install that, you need to run
}
local @ENV{keys %env} = values %env;
my $satisfied = eval { $self->satisfy_requires };
- return $self->goodbye($@) if $@;
- return unless $satisfied ;
+ if ($@) {
+ return $self->goodbye($@);
+ }
+ unless ($satisfied){
+ $self->post_make();
+ return;
+ }
if ($CPAN::Signal) {
delete $self->{force_update};
+ $self->post_make();
return;
}
# need to chdir again, because $self->satisfy_requires might change the directory
unless (chdir $builddir) {
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
+ $self->post_make();
return;
}
@@ -2816,12 +2852,16 @@ sub prereqs_for_slot {
if ($self->{CALLED_FOR} =~
/^(
CPAN::Meta::Requirements
+ |CPAN::DistnameInfo
|version
|parent
|ExtUtils::MakeMaker
|Test::Harness
)$/x) {
- $CPAN::Frontend->mywarn("Setting requirements to nil as a workaround\n");
+ $CPAN::Frontend->mywarn("Please install CPAN::Meta::Requirements ".
+ "as soon as possible; it is needed for a reliable operation of ".
+ "the cpan shell; setting requirements to nil for '$1' for now ".
+ "to prevent deadlock during bootstrapping\n");
return;
}
$before = " before $self->{CALLED_FOR}";
@@ -3555,24 +3595,30 @@ sub test {
$self->pre_test();
if (exists $self->{cleanup_after_install_done}) {
+ $self->post_test();
return $self->make;
}
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
if (my $goto = $self->prefs->{goto}) {
+ $self->post_test();
return $self->goto($goto);
}
- $self->make
- or return;
+ unless ($self->make){
+ $self->post_test();
+ return;
+ }
if ( defined( my $sc = $self->shortcut_test ) ) {
+ $self->post_test();
return $sc;
}
if ($CPAN::Signal) {
- delete $self->{force_update};
- return;
+ delete $self->{force_update};
+ $self->post_test();
+ return;
}
# warn "XDEBUG: checking for notest: $self->{notest} $self";
my $make = $self->{modulebuild} ? "Build" : "make";
@@ -3582,12 +3628,26 @@ sub test {
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
- local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # test
+ local $ENV{PERL_USE_UNSAFE_INC} =
+ exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
+ ? $ENV{PERL_USE_UNSAFE_INC} : 1; # test
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
+ if ($run_allow_installing_within_test) {
+ my($allow_installing, $why) = $self->_allow_installing;
+ if (! $allow_installing) {
+ $CPAN::Frontend->mywarn("Testing/Installation stopped: $why\n");
+ $self->introduce_myself;
+ $self->{make_test} = CPAN::Distrostatus->new("NO -- testing/installation stopped due $why");
+ $CPAN::Frontend->mywarn(" [testing] -- NOT OK\n");
+ delete $self->{force_update};
+ $self->post_test();
+ return;
+ }
+ }
$CPAN::Frontend->myprint(sprintf "Running %s test for %s\n", $make, $self->pretty_id);
my $builddir = $self->dir or
@@ -3595,6 +3655,7 @@ sub test {
unless (chdir $builddir) {
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
+ $self->post_test();
return;
}
@@ -3603,6 +3664,7 @@ sub test {
if ($^O eq 'MacOS') {
Mac::BuildTools::make_test($self);
+ $self->post_test();
return;
}
@@ -3614,9 +3676,10 @@ sub test {
# Test::Harness 3.0 self-tests, so that should be 'unless
# installing Test::Harness'
unless ($self->id eq $thm->distribution->id) {
- $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
+ $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
'$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
$self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
+ $self->post_test();
return;
}
}
@@ -3638,12 +3701,14 @@ sub test {
$CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
}
$CPAN::Frontend->myprint("Found prior test report -- OK\n");
+ $self->post_test();
return;
}
elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) {
$self->{make_test} = CPAN::Distrostatus->new("NO");
$self->{badtestcnt}++;
$CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n");
+ $self->post_test();
return;
}
}
@@ -3687,18 +3752,45 @@ sub test {
"testing without\n");
}
}
- if ($want_expect) {
- if ($self->_should_report('test')) {
- $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
- "not supported when distroprefs specify ".
- "an interactive test\n");
+
+ FORK: {
+ my $pid = fork;
+ if (! defined $pid) { # contention
+ warn "Contention '$!', sleeping 2";
+ sleep 2;
+ redo FORK;
+ } elsif ($pid) { # parent
+ if ($^O eq "MSWin32") {
+ wait;
+ } else {
+ SUPERVISE: while (waitpid($pid, WNOHANG) <= 0) {
+ if ($CPAN::Signal) {
+ kill 9, -$pid;
+ }
+ sleep 1;
+ }
+ }
+ $tests_ok = !$?;
+ } else { # child
+ POSIX::setsid() unless $^O eq "MSWin32";
+ my $c_ok;
+ $|=1;
+ if ($want_expect) {
+ if ($self->_should_report('test')) {
+ $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
+ "not supported when distroprefs specify ".
+ "an interactive test\n");
+ }
+ $c_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
+ } elsif ( $self->_should_report('test') ) {
+ $c_ok = CPAN::Reporter::test($self, $system);
+ } else {
+ $c_ok = system($system) == 0;
+ }
+ exit !$c_ok;
}
- $tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
- } elsif ( $self->_should_report('test') ) {
- $tests_ok = CPAN::Reporter::test($self, $system);
- } else {
- $tests_ok = system($system) == 0;
- }
+ } # FORK
+
$self->introduce_myself;
my $but = $self->_make_test_illuminate_prereqs();
if ( $tests_ok ) {
@@ -3706,6 +3798,7 @@ sub test {
$CPAN::Frontend->mywarn("Tests succeeded but $but\n");
$self->{make_test} = CPAN::Distrostatus->new("NO $but");
$self->store_persistent_state;
+ $self->post_test();
return $self->goodbye("[dependencies] -- NA");
}
$CPAN::Frontend->myprint(" $system -- OK\n");
@@ -3723,6 +3816,8 @@ sub test {
$self->{make_test} = CPAN::Distrostatus->new(
"NO but failure ignored because 'force' in effect"
);
+ } elsif ($CPAN::Signal) {
+ $self->{make_test} = CPAN::Distrostatus->new("NO -- Interrupted");
} else {
$self->{make_test} = CPAN::Distrostatus->new("NO");
}
@@ -3772,7 +3867,7 @@ sub _make_test_illuminate_prereqs {
if $CPAN::DEBUG;
} else {
push @prereq, $m
- if $m_obj->{mandatory};
+ unless $self->is_locally_optional(undef, $m);
}
}
my $but;
@@ -4095,7 +4190,9 @@ sub install {
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
- local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # install
+ local $ENV{PERL_USE_UNSAFE_INC} =
+ exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
+ ? $ENV{PERL_USE_UNSAFE_INC} : 1; # install
$CPAN::META->set_perl5lib;
local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
@@ -4106,6 +4203,18 @@ sub install {
}
local @ENV{keys %$install_env} = values %$install_env if $install_env;
+ if (! $run_allow_installing_within_test) {
+ my($allow_installing, $why) = $self->_allow_installing;
+ if (! $allow_installing) {
+ $CPAN::Frontend->mywarn("Installation stopped: $why\n");
+ $self->introduce_myself;
+ $self->{install} = CPAN::Distrostatus->new("NO -- installation stopped due $why");
+ $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
+ delete $self->{force_update};
+ $self->post_install();
+ return;
+ }
+ }
my($pipe) = FileHandle->new("$system $stderr |");
unless ($pipe) {
$CPAN::Frontend->mywarn("Can't execute $system: $!");
@@ -4177,6 +4286,162 @@ sub install {
return !! $close_ok;
}
+sub blib_pm_walk {
+ my @queue = grep { -e $_ } File::Spec->catdir("blib","lib"), File::Spec->catdir("blib","arch");
+ return sub {
+ LOOP: {
+ if (@queue) {
+ my $file = shift @queue;
+ if (-d $file) {
+ my $dh;
+ opendir $dh, $file or next;
+ my @newfiles = map {
+ my @ret;
+ my $maybedir = File::Spec->catdir($file, $_);
+ if (-d $maybedir) {
+ unless (File::Spec->catdir("blib","arch","auto") eq $maybedir) {
+ # prune the blib/arch/auto directory, no pm files there
+ @ret = $maybedir;
+ }
+ } elsif (/\.pm$/) {
+ my $mustbefile = File::Spec->catfile($file, $_);
+ if (-f $mustbefile) {
+ @ret = $mustbefile;
+ }
+ }
+ @ret;
+ } grep {
+ $_ ne "."
+ && $_ ne ".."
+ } readdir $dh;
+ push @queue, @newfiles;
+ redo LOOP;
+ } else {
+ return $file;
+ }
+ } else {
+ return;
+ }
+ }
+ };
+}
+
+sub _allow_installing {
+ my($self) = @_;
+ my $id = my $pretty_id = $self->pretty_id;
+ if ($self->{CALLED_FOR}) {
+ $id .= " (called for $self->{CALLED_FOR})";
+ }
+ my $allow_down = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_module_downgrades});
+ $allow_down ||= "ask/yes";
+ my $allow_outdd = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_outdated_dists});
+ $allow_outdd ||= "ask/yes";
+ return 1 if
+ $allow_down eq "yes"
+ && $allow_outdd eq "yes";
+ if (($allow_outdd ne "yes") && ! $CPAN::META->has_inst('CPAN::DistnameInfo')) {
+ return 1 if grep { $_ eq 'CPAN::DistnameInfo'} $self->containsmods;
+ if ($allow_outdd ne "yes") {
+ $CPAN::Frontend->mywarn("The current configuration of allow_installing_outdated_dists is '$allow_outdd', but for this option we would need 'CPAN::DistnameInfo' installed. Please install 'CPAN::DistnameInfo' as soon as possible. As long as we are not equipped with 'CPAN::DistnameInfo' this option does not take effect\n");
+ $allow_outdd = "yes";
+ }
+ }
+ return 1 if
+ $allow_down eq "yes"
+ && $allow_outdd eq "yes";
+ my($dist_version, $dist_dist);
+ if ($allow_outdd ne "yes"){
+ my $dni = CPAN::DistnameInfo->new($pretty_id);
+ $dist_version = $dni->version;
+ $dist_dist = $dni->dist;
+ }
+ my $iterator = blib_pm_walk();
+ my(@down,@outdd);
+ while (my $file = $iterator->()) {
+ my $version = CPAN::Module->parse_version($file);
+ my($volume, $directories, $pmfile) = File::Spec->splitpath( $file );
+ my @dirs = File::Spec->splitdir( $directories );
+ my(@blib_plus1) = splice @dirs, 0, 2;
+ my($pmpath) = File::Spec->catfile(grep { length($_) } @dirs, $pmfile);
+ unless ($allow_down eq "yes") {
+ if (my $inst_file = $self->_file_in_path($pmpath, \@INC)) {
+ my $inst_version = CPAN::Module->parse_version($inst_file);
+ my $cmp = CPAN::Version->vcmp($version, $inst_version);
+ if ($cmp) {
+ if ($cmp < 0) {
+ push @down, { pmpath => $pmpath, version => $version, inst_version => $inst_version };
+ }
+ }
+ if (@down) {
+ my $why = "allow_installing_module_downgrades: $id contains downgrading module(s) (e.g. '$down[0]{pmpath}' would downgrade installed '$down[0]{inst_version}' to '$down[0]{version}')";
+ if (my($default) = $allow_down =~ m|^ask/(.+)|) {
+ $default = "yes" unless $default =~ /^(y|n)/i;
+ my $answer = CPAN::Shell::colorable_makemaker_prompt
+ ("$why. Do you want to allow installing it?",
+ $default, "colorize_warn");
+ $allow_down = $answer =~ /^\s*y/i ? "yes" : "no";
+ }
+ if ($allow_down eq "no") {
+ return (0, $why);
+ }
+ }
+ }
+ }
+ unless ($allow_outdd eq "yes") {
+ my @pmpath = (@dirs, $pmfile);
+ $pmpath[-1] =~ s/\.pm$//;
+ my $mo = CPAN::Shell->expand("Module",join "::", grep { length($_) } @pmpath);
+ if ($mo) {
+ my $cpan_version = $mo->cpan_version;
+ my $is_lower = CPAN::Version->vlt($version, $cpan_version);
+ my $other_dist;
+ if (my $mo_dist = $mo->distribution) {
+ $other_dist = $mo_dist->pretty_id;
+ my $dni = CPAN::DistnameInfo->new($other_dist);
+ if ($dni->dist eq $dist_dist){
+ if (CPAN::Version->vgt($dni->version, $dist_version)) {
+ push @outdd, {
+ pmpath => $pmpath,
+ cpan_path => $dni->pathname,
+ dist_version => $dni->version,
+ dist_dist => $dni->dist,
+ };
+ }
+ }
+ }
+ }
+ if (@outdd && $allow_outdd ne "yes") {
+ my $why = "allow_installing_outdated_dists: $id contains module(s) that are indexed on the CPAN with a different distro: (e.g. '$outdd[0]{pmpath}' is indexed with '$outdd[0]{cpan_path}')";
+ if ($outdd[0]{dist_dist} eq $dist_dist) {
+ $why .= ", and this has a higher distribution-version, i.e. version '$outdd[0]{dist_version}' is higher than '$dist_version')";
+ }
+ if (my($default) = $allow_outdd =~ m|^ask/(.+)|) {
+ $default = "yes" unless $default =~ /^(y|n)/i;
+ my $answer = CPAN::Shell::colorable_makemaker_prompt
+ ("$why. Do you want to allow installing it?",
+ $default, "colorize_warn");
+ $allow_outdd = $answer =~ /^\s*y/i ? "yes" : "no";
+ }
+ if ($allow_outdd eq "no") {
+ return (0, $why);
+ }
+ }
+ }
+ }
+ return 1;
+}
+
+sub _file_in_path { # similar to CPAN::Module::_file_in_path
+ my($self,$pmpath,$incpath) = @_;
+ my($dir,@packpath);
+ foreach $dir (@$incpath) {
+ my $pmfile = File::Spec->catfile($dir,$pmpath);
+ if (-f $pmfile) {
+ return $pmfile;
+ }
+ }
+ return;
+}
sub introduce_myself {
my($self) = @_;
$CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id));
diff --git a/cpan/CPAN/lib/CPAN/FTP.pm b/cpan/CPAN/lib/CPAN/FTP.pm
index 6d9800e31b..1688a118e4 100644
--- a/cpan/CPAN/lib/CPAN/FTP.pm
+++ b/cpan/CPAN/lib/CPAN/FTP.pm
@@ -15,7 +15,7 @@ use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
use vars qw(
$VERSION
);
-$VERSION = "5.5011";
+$VERSION = "5.5012";
sub _plus_append_open {
my($fh, $file) = @_;
@@ -23,7 +23,7 @@ sub _plus_append_open {
mkpath $parent_dir;
my($cnt);
until (open $fh, "+>>$file") {
- next if $! == Errno::EAGAIN; # don't increment on EAGAIN
+ next if exists &Errno::EAGAIN && $! == &Errno::EAGAIN; # don't increment on EAGAIN
$CPAN::Frontend->mydie("Could not open '$file' after 10000 tries: $!") if ++$cnt > 100000;
sleep 0.0001;
mkpath $parent_dir;
@@ -34,6 +34,8 @@ sub _plus_append_open {
# if they want to rewrite, they need to pass in a filehandle
sub _ftp_statistics {
my($self,$fh) = @_;
+ my $ftpstats_size = $CPAN::Config->{ftpstats_size};
+ return if defined $ftpstats_size && $ftpstats_size <= 0;
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
@@ -120,18 +122,23 @@ sub _add_to_statistics {
my @debug;
@debug = $time if $sdebug;
my $fullstats = $self->_ftp_statistics($fh);
- close $fh;
+ close $fh if $fh && defined(fileno($fh));
$fullstats->{history} ||= [];
push @debug, scalar @{$fullstats->{history}} if $sdebug;
push @debug, time if $sdebug;
push @{$fullstats->{history}}, $stats;
# YAML.pm 0.62 is unacceptably slow with 999;
# YAML::Syck 0.82 has no noticable performance problem with 999;
- my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99;
+ my $ftpstats_size = $CPAN::Config->{ftpstats_size};
+ $ftpstats_size = 99 unless defined $ftpstats_size;
my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
while (
- @{$fullstats->{history}} > $ftpstats_size
- || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
+ @{$fullstats->{history} || []}
+ &&
+ (
+ @{$fullstats->{history}} > $ftpstats_size
+ || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
+ )
) {
shift @{$fullstats->{history}}
}
diff --git a/cpan/CPAN/lib/CPAN/FirstTime.pm b/cpan/CPAN/lib/CPAN/FirstTime.pm
index ae2f662261..af4a6d7759 100644
--- a/cpan/CPAN/lib/CPAN/FirstTime.pm
+++ b/cpan/CPAN/lib/CPAN/FirstTime.pm
@@ -11,7 +11,7 @@ use File::Spec ();
use CPAN::Mirrors ();
use CPAN::Version ();
use vars qw($VERSION $auto_config);
-$VERSION = "5.5313";
+$VERSION = "5.5314";
=head1 NAME
@@ -38,6 +38,34 @@ my @podpara = split /\n\n/, <<'=back';
=over 2
+=item allow_installing_module_downgrades
+
+The CPAN shell can watch the C<blib/> directories that are built up
+before running C<make test> to determine whether the current
+distribution will end up with modules being overwritten with decreasing module version numbers. It
+can then let the build of this distro fail when it discovers a
+downgrade.
+
+Do you want to allow installing distros with decreasing module
+versions compared to what you have installed (yes, no, ask/yes,
+ask/no)?
+
+=item allow_installing_outdated_dists
+
+The CPAN shell can watch the C<blib/> directories that are built up
+before running C<make test> to determine whether the current
+distribution contains modules that are indexed with a distro with a
+higher distro-version number than the current one. It can
+then let the build of this distro fail when it would not represent the
+most up-to-date version of the distro.
+
+Note: choosing anyhing but 'yes' for this option will need
+Devel::DistnameInfo being installed for taking effect.
+
+Do you want to allow installing distros that are not indexed as the
+highest distro-version for all contained modules (yes, no, ask/yes,
+ask/no)?
+
=item auto_commit
Normally CPAN.pm keeps config variables in memory and changes need to
@@ -193,7 +221,8 @@ How many days shall we keep statistics about downloads?
=item ftpstats_size
Statistics about downloads are truncated by size and period
-simultaneously.
+simultaneously. Setting this to zero or negative disables download
+statistics.
How many items shall we keep in the statistics about downloads?
@@ -568,6 +597,23 @@ regardless of the history using "force".
Do you want to rely on the test report history (yes/no)?
+=item urllist_ping_external
+
+When automatic selection of the nearest cpan mirrors is performed,
+turn on the use of the external ping via Net::Ping::External. This is
+recommended in the case the local network has a transparent proxy.
+
+Do you want to use the external ping command when autoselecting
+mirrors?
+
+=item urllist_ping_verbose
+
+When automatic selection of the nearest cpan mirrors is performed,
+this option can be used to turn on verbosity during the selection
+process.
+
+Do you want to see verbosity turned on when autoselecting mirrors?
+
=item use_prompt_default
When this is true, CPAN will set PERL_MM_USE_DEFAULT to a true
@@ -1089,6 +1135,14 @@ sub init {
my_dflt_prompt(mbuild_install_arg => "", $matcher);
+ for my $o (qw(
+ allow_installing_outdated_dists
+ allow_installing_module_downgrades
+ )) {
+ my_prompt_loop($o => 'ask/no', $matcher,
+ 'yes|no|ask/yes|ask/no');
+ }
+
#
#== use_prompt_default
#
@@ -1264,6 +1318,12 @@ sub init {
# Allow matching but don't show during manual config
if ($matcher) {
+ if ("urllist_ping_external" =~ $matcher) {
+ my_yn_prompt(urllist_ping_external => 0, $matcher);
+ }
+ if ("urllist_ping_verbose" =~ $matcher) {
+ my_yn_prompt(urllist_ping_verbose => 0, $matcher);
+ }
if ("randomize_urllist" =~ $matcher) {
my_dflt_prompt(randomize_urllist => 0, $matcher);
}
@@ -1679,7 +1739,6 @@ sub my_yn_prompt {
my $default;
defined($default = $CPAN::Config->{$item}) or $default = $dflt;
- # $DB::single = 1;
if (!$auto_config && (!$m || $item =~ /$m/)) {
if (my $intro = $prompts{$item . "_intro"}) {
$CPAN::Frontend->myprint($intro);
@@ -1917,17 +1976,25 @@ sub auto_mirrored_by {
my $mirrors = CPAN::Mirrors->new($local);
my $cnt = 0;
+ my $callback_was_active = 0;
my @best = $mirrors->best_mirrors(
how_many => 3,
callback => sub {
+ $callback_was_active++;
$CPAN::Frontend->myprint(".");
if ($cnt++>60) { $cnt=0; $CPAN::Frontend->myprint("\n"); }
},
+ $CPAN::Config->{urllist_ping_external} ? (external_ping => 1) : (),
+ $CPAN::Config->{urllist_ping_verbose} ? (verbose => 1) : (),
);
- my $urllist = [ map { $_->http } @best ];
+ my $urllist = [
+ map { $_->http }
+ grep { $_ && ref $_ && $_->can('http') }
+ @best
+ ];
push @$urllist, grep { /^file:/ } @{$CPAN::Config->{urllist}};
- $CPAN::Frontend->myprint(" done!\n\n");
+ $CPAN::Frontend->myprint(" done!\n\n") if $callback_was_active;
return $urllist
}
diff --git a/cpan/CPAN/lib/CPAN/HandleConfig.pm b/cpan/CPAN/lib/CPAN/HandleConfig.pm
index 6cc12af667..e24a969c11 100644
--- a/cpan/CPAN/lib/CPAN/HandleConfig.pm
+++ b/cpan/CPAN/lib/CPAN/HandleConfig.pm
@@ -12,7 +12,7 @@ CPAN::HandleConfig - internal configuration handling for CPAN.pm
=cut
-$VERSION = "5.5009"; # see also CPAN::Config::VERSION at end of file
+$VERSION = "5.5011"; # see also CPAN::Config::VERSION at end of file
%can = (
commit => "Commit changes to disk",
@@ -33,6 +33,8 @@ $VERSION = "5.5009"; # see also CPAN::Config::VERSION at end of file
%keys = map { $_ => undef }
(
+ "allow_installing_module_downgrades",
+ "allow_installing_outdated_dists",
"applypatch",
"auto_commit",
"build_cache",
@@ -112,6 +114,8 @@ $VERSION = "5.5009"; # see also CPAN::Config::VERSION at end of file
"trust_test_report_history",
"unzip",
"urllist",
+ "urllist_ping_verbose",
+ "urllist_ping_external",
"use_prompt_default",
"use_sqlite",
"username",
@@ -124,6 +128,8 @@ $VERSION = "5.5009"; # see also CPAN::Config::VERSION at end of file
my %prefssupport = map { $_ => 1 }
(
+ "allow_installing_module_downgrades",
+ "allow_installing_outdated_dists",
"build_requires_install_policy",
"check_sigs",
"make",
@@ -770,7 +776,7 @@ sub prefs_lookup {
use strict;
use vars qw($AUTOLOAD $VERSION);
- $VERSION = "5.5008";
+ $VERSION = "5.5011";
# formerly CPAN::HandleConfig was known as CPAN::Config
sub AUTOLOAD { ## no critic
diff --git a/cpan/CPAN/lib/CPAN/Mirrors.pm b/cpan/CPAN/lib/CPAN/Mirrors.pm
index 29bb7216ff..721ead2a85 100644
--- a/cpan/CPAN/lib/CPAN/Mirrors.pm
+++ b/cpan/CPAN/lib/CPAN/Mirrors.pm
@@ -19,7 +19,7 @@ CPAN::Mirrors - Get CPAN mirror information and select a fast one
my( $m ) = @_;
printf "%s = %s\n", $m->hostname, $m->rtt
};
- $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback );
+ $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback, %args );
@mirrors = sort { $a->rtt <=> $b->rtt } @mirrors;
@@ -34,12 +34,13 @@ CPAN::Mirrors - Get CPAN mirror information and select a fast one
package CPAN::Mirrors;
use strict;
use vars qw($VERSION $urllist $silent);
-$VERSION = "2.21";
+$VERSION = "2.27";
use Carp;
use FileHandle;
use Fcntl ":flock";
use Net::Ping ();
+use CPAN::Version;
=item new( LOCAL_FILE_NAME )
@@ -82,7 +83,7 @@ Return a list of continents based on those defined in F<MIRRORED.BY>.
sub continents {
my ($self) = @_;
- return sort keys %{$self->{geography}};
+ return sort keys %{$self->{geography} || {}};
}
=item countries( [CONTINENTS] )
@@ -99,7 +100,7 @@ sub countries {
@continents = $self->continents unless @continents;
my @countries;
for my $c (@continents) {
- push @countries, sort keys %{ $self->{geography}{$c} };
+ push @countries, sort keys %{ $self->{geography}{$c} || {} };
}
return @countries;
}
@@ -165,22 +166,25 @@ dynamic DNS to give a close mirror.
=cut
-sub default_mirror { 'http://www.cpan.org/' }
+sub default_mirror {
+ CPAN::Mirrored::By->new({ http => 'http://www.cpan.org/'});
+}
=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.
+C<how_many>. In list context, it returns up to C<how_many> mirrors.
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
+ 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
+ external_ping - if true, use external ping via Net::Ping::External. Default: false
If you don't specify the continents, C<best_mirrors> calls
C<find_best_continents> to get the list of continents to check.
@@ -188,6 +192,9 @@ C<find_best_continents> to get the list of continents to check.
If you don't have L<Net::Ping> v2.13 or later, needed for timings,
this returns the default mirror.
+C<external_ping> should be set and then C<Net::Ping::External> needs
+to be installed, if the local network has a transparent proxy.
+
=cut
sub best_mirrors {
@@ -197,10 +204,12 @@ sub best_mirrors {
my $verbose = defined $args{verbose} ? $args{verbose} : 0;
my $continents = $args{continents} || [];
$continents = [$continents] unless ref $continents;
+ $args{external_ping} = 0 unless defined $args{external_ping};
+ my $external_ping = $args{external_ping};
# Old Net::Ping did not do timings at all
my $min_version = '2.13';
- unless( Net::Ping->VERSION gt $min_version ) {
+ unless( CPAN::Version->vgt(Net::Ping->VERSION, $min_version) ) {
carp sprintf "Net::Ping version is %s (< %s). Returning %s",
Net::Ping->VERSION, $min_version, $self->default_mirror;
return $self->default_mirror;
@@ -211,9 +220,10 @@ sub best_mirrors {
if ( ! @$continents ) {
print "Searching for the best continent ...\n" if $verbose;
my @best_continents = $self->find_best_continents(
- seen => $seen,
- verbose => $verbose,
- callback => $callback,
+ seen => $seen,
+ verbose => $verbose,
+ callback => $callback,
+ external_ping => $external_ping,
);
# Only add enough continents to find enough mirrors
@@ -225,12 +235,18 @@ sub best_mirrors {
}
}
+ return $self->default_mirror unless @$continents;
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;
+ my $timings = $self->get_mirrors_timings(
+ $trial_mirrors,
+ $seen,
+ $callback,
+ %args,
+ );
+ return $self->default_mirror unless @$timings;
$how_many = @$timings if $how_many > @$timings;
@@ -268,7 +284,7 @@ sub get_n_random_mirrors_by_continents {
\@long_list;
}
-=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK );
+=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK, %ARGS );
Pings the listed mirrors and returns a list of mirrors sorted in
ascending ping times.
@@ -286,7 +302,7 @@ ping.
=cut
sub get_mirrors_timings {
- my( $self, $mirror_list, $seen, $callback ) = @_;
+ my( $self, $mirror_list, $seen, $callback, %args ) = @_;
$seen = {} unless defined $seen;
croak "The mirror list argument must be an array reference"
@@ -302,8 +318,9 @@ sub get_mirrors_timings {
next unless eval{ $m->http };
if( $self->_try_a_ping( $seen, $m, ) ) {
- my $ping = $m->ping;
+ my $ping = $m->ping(%args);
next unless defined $ping;
+ # printf "m %s ping %s\n", $m, $ping;
push @$timings, $m;
$callback->( $m ) if $callback;
}
@@ -367,20 +384,21 @@ value.
sub find_best_continents {
my ($self, %args) = @_;
- $args{n} ||= 3;
+ $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};
+ unless defined $args{ping_cache_limit};
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) );
+ printf "Testing %s (%d mirrors)\n", $c, scalar @mirrors
+ if $args{verbose};
next CONT unless @mirrors;
my $n = (@mirrors < $args{n}) ? @mirrors : $args{n};
@@ -389,11 +407,18 @@ sub find_best_continents {
my $tries = 0;
RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) {
my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
- if( $self->_try_a_ping( $args{seen}, $m, $args{ping_cache_limit} ) ) {
- $self->get_mirrors_timings( [ $m ], $args{seen}, $args{callback} );
+ if( $self->_try_a_ping(
+ $args{seen}, $m, $args{ping_cache_limit}
+ )) {
+ $self->get_mirrors_timings(
+ [ $m ],
+ $args{seen},
+ $args{callback},
+ %args,
+ );
next RANDOM unless defined $args{seen}{$m->hostname}->rtt;
}
- printf "\t%s -> %0.2f ms\n",
+ printf "(%s -> %0.2f ms)",
$m->hostname,
join ' ', 1000 * $args{seen}{$m->hostname}->rtt
if $args{verbose};
@@ -409,8 +434,12 @@ sub find_best_continents {
if ( $args{verbose} ) {
print "Median result by continent:\n";
- for my $c ( @best_cont ) {
- printf( " %4d ms %s\n", int($medians{$c}*1000+.5), $c );
+ if ( @best_cont ) {
+ for my $c ( @best_cont ) {
+ printf( " %7.2f ms %s\n", $medians{$c}*1000, $c );
+ }
+ } else {
+ print " **** No results found ****\n"
}
}
@@ -421,12 +450,14 @@ sub find_best_continents {
sub _try_a_ping {
my ($self, $seen, $mirror, $ping_cache_limit ) = @_;
- ( ! exists $seen->{$mirror->hostname} )
+ ( ! exists $seen->{$mirror->hostname}
or
- (
! defined $seen->{$mirror->hostname}->rtt
- or
- time - $seen->{$mirror->hostname}->rtt > $ping_cache_limit
+ or
+ ! defined $ping_cache_limit
+ or
+ time - $seen->{$mirror->hostname}->ping_time
+ > $ping_cache_limit
)
}
@@ -445,7 +476,13 @@ sub _get_median_ping_time {
}
};
- printf "\t-->median time: %0.2f ms\n", $median * 1000 if $verbose;
+ if ($verbose){
+ if ($median) {
+ printf " => median time: %.2f ms\n", $median * 1000
+ } else {
+ printf " => **** no median time ****\n";
+ }
+ }
return $median;
}
@@ -546,9 +583,17 @@ sub url {
}
sub ping {
- my $self = shift;
+ my($self, %args) = @_;
- my $ping = Net::Ping->new($^O eq 'VMS' ? 'icmp' : 'tcp', 1);
+ my $external_ping = $args{external_ping};
+ if ($external_ping) {
+ eval { require Net::Ping::External }
+ or die "Net::Ping::External required to use external ping command";
+ }
+ my $ping = Net::Ping->new(
+ $external_ping ? 'external' : $^O eq 'VMS' ? 'icmp' : 'tcp',
+ 1
+ );
my ($proto) = $self->url =~ m{^([^:]+)};
my $port = $proto eq 'http' ? 80 : 21;
return unless $port;
@@ -561,7 +606,11 @@ sub ping {
}
$ping->hires(1) if $ping->can('hires');
- my ($alive,$rtt) = $ping->ping($self->hostname);
+ my ($alive,$rtt) = eval { $ping->ping($self->hostname); };
+ my $verbose = $args{verbose};
+ if ($verbose && !$alive) {
+ printf "(host %s not alive)", $self->hostname;
+ }
$self->{rtt} = $alive ? $rtt : undef;
$self->{ping_time} = time;
diff --git a/cpan/CPAN/scripts/cpan b/cpan/CPAN/scripts/cpan
index 0041b8ab20..4e900b0054 100644
--- a/cpan/CPAN/scripts/cpan
+++ b/cpan/CPAN/scripts/cpan
@@ -4,7 +4,12 @@ BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use vars qw($VERSION);
-use App::Cpan '1.64';
+use App::Cpan;
+use CPAN::Version;
+my $minver = '1.64';
+if ( CPAN::Version->vlt($App::Cpan::VERSION, $minver) ) {
+ warn "WARNING: your version of App::Cpan is $App::Cpan::VERSION while we would expect at least $minver";
+}
$VERSION = '1.64';
my $rc = App::Cpan->run( @ARGV );