diff options
author | Andreas Koenig <root@dubravka.in-berlin.de> | 2019-06-13 19:04:47 +0000 |
---|---|---|
committer | Karen Etheridge <ether@cpan.org> | 2019-06-20 09:19:40 -0700 |
commit | 5cf88abdca2d5d3d5c7adb953cb5f971f3c4539a (patch) | |
tree | 74c07a135f10172e8b54c0c6a296dee973060596 /cpan | |
parent | d2ece0ba72dfad1ecde95093c98e71b716988eb4 (diff) | |
download | perl-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.pm | 77 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/Bundle.pm | 15 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/Distribution.pm | 339 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/FTP.pm | 19 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/FirstTime.pm | 77 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/HandleConfig.pm | 10 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/Mirrors.pm | 119 | ||||
-rw-r--r-- | cpan/CPAN/scripts/cpan | 7 |
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 ); |