summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPAN
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2021-03-03 11:04:20 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2021-03-03 11:04:20 +0000
commit13c3572d26e0868b9665513e4646ade860ae7810 (patch)
tree72f68d7c1270cc0a1d504f8eeb45d4de6b36f2d1 /Master/tlpkg/tlperl/lib/CPAN
parent87d16a01498a53c4bb455d78ae7131370e47591e (diff)
Updated tlperl
git-svn-id: svn://tug.org/texlive/trunk@58075 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPAN')
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Bundle.pm16
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Distribution.pm415
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/FTP.pm19
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm83
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm12
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm119
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Queue.pm13
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Shell.pm9
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm21
9 files changed, 596 insertions, 111 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Bundle.pm b/Master/tlpkg/tlperl/lib/CPAN/Bundle.pm
index 3b4e93d8bf6..99c95ac4d6e 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Bundle.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Bundle.pm
@@ -8,7 +8,7 @@ use CPAN::Module;
use vars qw(
$VERSION
);
-$VERSION = "5.5003";
+$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)
@@ -238,6 +243,7 @@ Going to $meth that.
$self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
my $obj = $CPAN::META->instance($type,$s);
$obj->{reqtype} = $self->{reqtype};
+ $obj->{viabundle} ||= { id => $id, reqtype => $self->{reqtype}, optional => !$self->{mandatory}};
# $obj->$meth();
# XXX should optional be based on whether bundle was optional? -- xdg, 2012-04-01
# A: Sure, what could demand otherwise? --andk, 2013-11-25
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm b/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm
index 717c9aa0e45..34121085395 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm
+++ b/Master/tlpkg/tlperl/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.22";
+$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
@@ -317,6 +320,17 @@ sub called_for {
sub shortcut_get {
my ($self) = @_;
+ if (exists $self->{cleanup_after_install_done}) {
+ if ($self->{force_update}) {
+ delete $self->{cleanup_after_install_done};
+ } else {
+ my $id = $self->{CALLED_FOR} || $self->pretty_id;
+ return $self->success(
+ "Has already been *installed and cleaned up in the staging area* within this session, will not work on it again; if you really want to start over, try something like `force get $id`"
+ );
+ }
+ }
+
if (my $why = $self->check_disabled) {
$self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
# XXX why is this goodbye() instead of just print/warn?
@@ -366,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;
}
@@ -388,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};
@@ -408,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();
@@ -529,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",
@@ -554,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;
@@ -572,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 = $!;
@@ -1217,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;
}
@@ -1637,23 +1663,28 @@ sub force {
"prefs",
"prefs_file",
"prefs_file_doc",
+ "cleanup_after_install_done",
],
make => [
"writemakefile",
"make",
"modulebuild",
"prereq_pm",
+ "cleanup_after_install_done",
],
test => [
"badtestcnt",
"make_test",
- ],
+ "cleanup_after_install_done",
+ ],
install => [
"install",
+ "cleanup_after_install_done",
],
unknown => [
"reqtype",
"yaml_content",
+ "cleanup_after_install_done",
],
);
my $methodmatch = 0;
@@ -1830,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
@@ -1992,7 +2025,9 @@ sub prepare {
($output, $ret) = eval { CPAN::Reporter::record_command($system) };
if (! defined $output or $@) {
my $err = $@ || "Unknown error";
- $CPAN::Frontend->mywarn("Error while running PL phase: $err");
+ $CPAN::Frontend->mywarn("Error while running PL phase: $err\n");
+ $self->{writemakefile} = CPAN::Distrostatus
+ ->new("NO '$system' returned status $ret and no output");
return $self->goodbye("$system -- NOT OK");
}
CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
@@ -2062,8 +2097,14 @@ 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
@@ -2100,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;
}
@@ -2121,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;
}
@@ -2130,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;
}
@@ -2151,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;
}
@@ -2794,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}";
@@ -2956,7 +3018,8 @@ sub unsat_prereq {
next NEED;
}
} elsif (
- $self->{reqtype} =~ /^(r|c)$/
+ $self->{reqtype} # e.g. maybe we came via goto?
+ && $self->{reqtype} =~ /^(r|c)$/
&& ( exists $prereq_pm->{requires}{$need_module}
|| exists $prereq_pm->{opt_requires}{$need_module} )
&& $nmo
@@ -3531,21 +3594,31 @@ 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";
@@ -3555,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
@@ -3568,6 +3655,7 @@ sub test {
unless (chdir $builddir) {
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
+ $self->post_test();
return;
}
@@ -3576,6 +3664,7 @@ sub test {
if ($^O eq 'MacOS') {
Mac::BuildTools::make_test($self);
+ $self->post_test();
return;
}
@@ -3587,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;
}
}
@@ -3611,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;
}
}
@@ -3660,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 ) {
@@ -3679,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");
@@ -3696,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");
}
@@ -3745,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;
@@ -3895,7 +4017,12 @@ sub goto {
# and run where we left off
my($method) = (caller(1))[3];
- CPAN->instance("CPAN::Distribution",$goto)->$method();
+ my $goto_do = CPAN->instance("CPAN::Distribution",$goto);
+ $goto_do->called_for($self->called_for) unless $goto_do->called_for;
+ $goto_do->{mandatory} ||= $self->{mandatory};
+ $goto_do->{reqtype} ||= $self->{reqtype};
+ $goto_do->{coming_from} = $self->pretty_id;
+ $goto_do->$method();
CPAN::Queue->delete_first($goto);
# XXX delete_first returns undef; is that what this should return
# up the call stack, eg. return $sefl->goto($goto) -- xdg, 2012-04-04
@@ -3932,12 +4059,36 @@ sub shortcut_install {
return undef;
}
+#-> sub CPAN::Distribution::is_being_sponsored ;
+
+# returns true if we find a distro object in the queue that has
+# sponsored this one
+sub is_being_sponsored {
+ my($self) = @_;
+ my $iterator = CPAN::Queue->iterator;
+ QITEM: while (my $q = $iterator->()) {
+ my $s = $q->as_string;
+ my $obj = CPAN::Shell->expandany($s) or next QITEM;
+ my $type = ref $obj;
+ if ( $type eq 'CPAN::Distribution' ){
+ for my $module (sort keys %{$obj->{sponsored_mods} || {}}) {
+ return 1 if grep { $_ eq $module } $self->containsmods;
+ }
+ }
+ }
+ return 0;
+}
+
#-> sub CPAN::Distribution::install ;
sub install {
my($self) = @_;
$self->pre_install();
+ if (exists $self->{cleanup_after_install_done}) {
+ return $self->test;
+ }
+
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
if (my $goto = $self->prefs->{goto}) {
$self->goto($goto);
@@ -4039,11 +4190,31 @@ 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};
+ my $install_env;
+ if ($self->prefs->{install}) {
+ $install_env = $self->prefs->{install}{env};
+ }
+ 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: $!");
@@ -4069,7 +4240,8 @@ sub install {
$CPAN::META->is_installed($self->{build_dir});
$self->{install} = CPAN::Distrostatus->new("YES");
if ($CPAN::Config->{'cleanup_after_install'}
- && ! $self->is_dot_dist) {
+ && ! $self->is_dot_dist
+ && ! $self->is_being_sponsored) {
my $parent = File::Spec->catdir( $self->{build_dir}, File::Spec->updir );
chdir $parent or $CPAN::Frontend->mydie("Couldn't chdir to $parent: $!\n");
File::Path::rmtree($self->{build_dir});
@@ -4077,6 +4249,7 @@ sub install {
if (-e $yml) {
unlink $yml or $CPAN::Frontend->mydie("Couldn't unlink $yml: $!\n");
}
+ $self->{cleanup_after_install_done}=1;
}
} else {
$self->{install} = CPAN::Distrostatus->new("NO");
@@ -4113,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));
@@ -4361,6 +4690,8 @@ sub _should_report {
die "_should_report() requires a 'phase' argument"
if ! defined $phase;
+ return unless $CPAN::META->has_usable("CPAN::Reporter");
+
# configured
my $test_report = CPAN::HandleConfig->prefs_lookup($self,
q{test_report});
diff --git a/Master/tlpkg/tlperl/lib/CPAN/FTP.pm b/Master/tlpkg/tlperl/lib/CPAN/FTP.pm
index 6d9800e31b1..1688a118e4c 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/FTP.pm
+++ b/Master/tlpkg/tlperl/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/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm b/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm
index 49fa8ab7b95..af4a6d77591 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm
@@ -9,8 +9,9 @@ use File::Basename ();
use File::Path ();
use File::Spec ();
use CPAN::Mirrors ();
+use CPAN::Version ();
use vars qw($VERSION $auto_config);
-$VERSION = "5.5311";
+$VERSION = "5.5314";
=head1 NAME
@@ -37,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
@@ -192,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?
@@ -567,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
@@ -1088,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
#
@@ -1263,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);
}
@@ -1450,7 +1511,7 @@ sub _do_pick_mirrors {
$CPAN::Frontend->myprint($prompts{urls_intro});
# Only prompt for auto-pick if Net::Ping is new enough to do timings
my $_conf = 'n';
- if ( $CPAN::META->has_usable("Net::Ping") && Net::Ping->VERSION gt '2.13') {
+ if ( $CPAN::META->has_usable("Net::Ping") && CPAN::Version->vgt(Net::Ping->VERSION, '2.13')) {
$_conf = prompt($prompts{auto_pick}, "yes");
} else {
prompt("Autoselection disabled due to Net::Ping missing or insufficient. Please press ENTER");
@@ -1678,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);
@@ -1697,7 +1757,8 @@ sub my_prompt_loop {
my $ans;
if (!$auto_config && (!$m || $item =~ /$m/)) {
- $CPAN::Frontend->myprint($prompts{$item . "_intro"});
+ my $intro = $prompts{$item . "_intro"};
+ $CPAN::Frontend->myprint($intro) if defined $intro;
$CPAN::Frontend->myprint(" <$item>\n");
do { $ans = prompt($prompts{$item}, $default);
} until $ans =~ /$ok/;
@@ -1915,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/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm b/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm
index c72439f92cb..e24a969c11f 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm
@@ -12,7 +12,7 @@ CPAN::HandleConfig - internal configuration handling for CPAN.pm
=cut
-$VERSION = "5.5008"; # 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.5008"; # 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.5008"; # 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.5008"; # 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",
@@ -751,7 +757,7 @@ sub prefs_lookup {
return $distro->prefs->{cpanconfig}{$what};
} else {
$CPAN::Frontend->mywarn("Warning: $what not yet officially ".
- "supported for distroprefs, doing a normal lookup");
+ "supported for distroprefs, doing a normal lookup\n");
return $CPAN::Config->{$what};
}
}
@@ -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/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
index 29bb7216ffc..721ead2a85d 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
+++ b/Master/tlpkg/tlperl/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/Master/tlpkg/tlperl/lib/CPAN/Queue.pm b/Master/tlpkg/tlperl/lib/CPAN/Queue.pm
index 8027d22d3b2..259e47e05f7 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Queue.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Queue.pm
@@ -72,7 +72,7 @@ package CPAN::Queue;
# in CPAN::Distribution::rematein.
use vars qw{ @All $VERSION };
-$VERSION = "5.5002";
+$VERSION = "5.5003";
# CPAN::Queue::queue_item ;
sub queue_item {
@@ -207,6 +207,17 @@ sub reqtype_of {
return $best;
}
+sub iterator {
+ my $i = 0;
+ return sub {
+ until ($All[$i] || $i > $#All) {
+ $i++;
+ }
+ return if $i > $#All;
+ return $All[$i++]
+ };
+}
+
1;
__END__
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Shell.pm b/Master/tlpkg/tlperl/lib/CPAN/Shell.pm
index b5d88924df9..4140fb8af23 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Shell.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Shell.pm
@@ -47,7 +47,7 @@ use vars qw(
"CPAN/Tarzip.pm",
"CPAN/Version.pm",
);
-$VERSION = "5.5008";
+$VERSION = "5.5009";
# record the initial timestamp for reload.
$reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo };
@CPAN::Shell::ISA = qw(CPAN::Debug);
@@ -1611,9 +1611,10 @@ sub mydie {
# sub CPAN::Shell::colorable_makemaker_prompt ;
sub colorable_makemaker_prompt {
- my($foo,$bar) = @_;
+ my($foo,$bar,$ornament) = @_;
+ $ornament ||= "colorize_print";
if (CPAN::Shell->colorize_output) {
- my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
+ my $ornament = $CPAN::Config->{$ornament}||'bold blue on_white';
my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
print $color_on;
}
@@ -1867,7 +1868,7 @@ to find objects with matching identifiers.
}
}
if (UNIVERSAL::can($obj, 'called_for')) {
- $obj->called_for($s);
+ $obj->called_for($s) unless $obj->called_for;
}
CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm b/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm
index f585a01bf72..6517cb8fd72 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm
@@ -4,7 +4,7 @@ use strict;
use vars qw($VERSION @ISA $BUGHUNTING);
use CPAN::Debug;
use File::Basename qw(basename);
-$VERSION = "5.5012";
+$VERSION = "5.5013";
# module is internal to CPAN.pm
@ISA = qw(CPAN::Debug); ## no critic
@@ -41,6 +41,11 @@ CPAN shell prompt to register it as external program.
bless $me, $class;
}
+sub _zlib_ok () {
+ $CPAN::META->has_inst("Compress::Zlib") or return;
+ Compress::Zlib->can('gzopen');
+}
+
sub _my_which {
my($what) = @_;
if ($CPAN::Config->{$what}) {
@@ -66,7 +71,7 @@ sub _my_which {
sub gzip {
my($self,$read) = @_;
my $write = $self->{FILE};
- if ($CPAN::META->has_inst("Compress::Zlib")) {
+ if (_zlib_ok) {
my($buffer,$fhw);
$fhw = FileHandle->new($read)
or $CPAN::Frontend->mydie("Could not open $read: $!");
@@ -89,7 +94,7 @@ sub gzip {
sub gunzip {
my($self,$write) = @_;
my $read = $self->{FILE};
- if ($CPAN::META->has_inst("Compress::Zlib")) {
+ if (_zlib_ok) {
my($buffer,$fhw);
$fhw = FileHandle->new(">$write")
or $CPAN::Frontend->mydie("Could not open >$write: $!");
@@ -120,7 +125,7 @@ sub gtest {
my($buffer,$len);
$len = 0;
my $gz = Compress::Bzip2::bzopen($read, "rb")
- or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
+ or $CPAN::Frontend->mydie(sprintf("Cannot bzopen %s: %s\n",
$read,
$Compress::Bzip2::bzerrno));
while ($gz->bzread($buffer) > 0 ) {
@@ -135,7 +140,7 @@ sub gtest {
}
$gz->gzclose();
CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
- } elsif ( $read=~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib") ) {
+ } elsif ( $read=~/\.(?:gz|tgz)$/ && _zlib_ok ) {
# After I had reread the documentation in zlib.h, I discovered that
# uncompressed files do not lead to an gzerror (anymore?).
my($buffer,$len);
@@ -183,7 +188,7 @@ sub TIEHANDLE {
$CPAN::Frontend->mydie("Could not bzopen $file");
$self->{GZ} = $gz;
$class->debug("via Compress::Bzip2");
- } elsif ($file =~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib")) {
+ } elsif ($file =~/\.(?:gz|tgz)$/ && _zlib_ok) {
my $gz = Compress::Zlib::gzopen($file,"rb") or
$CPAN::Frontend->mydie("Could not gzopen $file");
$self->{GZ} = $gz;
@@ -260,7 +265,7 @@ sub untar {
} elsif (
$CPAN::META->has_usable("Archive::Tar")
&&
- $CPAN::META->has_inst("Compress::Zlib") ) {
+ _zlib_ok ) {
my $prefer_external_tar = $CPAN::Config->{prefer_external_tar};
unless (defined $prefer_external_tar) {
if ($^O =~ /(MSWin32|solaris)/) {
@@ -294,7 +299,7 @@ END_WARN
$foundAT = "nothing";
}
my $foundCZ;
- if ($CPAN::META->has_inst("Compress::Zlib")) {
+ if (_zlib_ok) {
$foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION;
} elsif ($foundAT) {
$foundCZ = "nothing";