[PATCH] Updates CPAN.pm to ANDK/CPAN-2.27-TRIAL2.tar.gz
authorAndreas Koenig <root@dubravka.in-berlin.de>
Thu, 13 Jun 2019 19:04:47 +0000 (19:04 +0000)
committerKaren Etheridge <ether@cpan.org>
Thu, 20 Jun 2019 16:19:40 +0000 (09:19 -0700)
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

Porting/Maintainers.pl
cpan/CPAN/lib/CPAN.pm
cpan/CPAN/lib/CPAN/Bundle.pm
cpan/CPAN/lib/CPAN/Distribution.pm
cpan/CPAN/lib/CPAN/FTP.pm
cpan/CPAN/lib/CPAN/FirstTime.pm
cpan/CPAN/lib/CPAN/HandleConfig.pm
cpan/CPAN/lib/CPAN/Mirrors.pm
cpan/CPAN/scripts/cpan

index a087d05..c3d11dd 100755 (executable)
@@ -253,7 +253,7 @@ use File::Glob qw(:case);
     },
 
     'CPAN' => {
-        'DISTRIBUTION' => 'ANDK/CPAN-2.26.tar.gz',
+        'DISTRIBUTION' => 'ANDK/CPAN-2.27-TRIAL2.tar.gz',
         'FILES'        => q[cpan/CPAN],
         'EXCLUDED'     => [
             qr{^distroprefs/},
index a25a5fa..2d87f47 100644 (file)
@@ -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
index 9270502..99c95ac 100644 (file)
@@ -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)
index ea637c8..3412108 100644 (file)
@@ -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));
index 6d9800e..1688a11 100644 (file)
@@ -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}}
         }
index ae2f662..af4a6d7 100644 (file)
@@ -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
 }
index 6cc12af..e24a969 100644 (file)
@@ -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
index 29bb721..721ead2 100644 (file)
@@ -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;
index 0041b8a..4e900b0 100644 (file)
@@ -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 );