diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2021-03-03 11:04:20 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2021-03-03 11:04:20 +0000 |
commit | 13c3572d26e0868b9665513e4646ade860ae7810 (patch) | |
tree | 72f68d7c1270cc0a1d504f8eeb45d4de6b36f2d1 /Master/tlpkg/tlperl/lib/CPAN | |
parent | 87d16a01498a53c4bb455d78ae7131370e47591e (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.pm | 16 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPAN/Distribution.pm | 415 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPAN/FTP.pm | 19 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm | 83 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm | 12 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm | 119 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPAN/Queue.pm | 13 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPAN/Shell.pm | 9 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm | 21 |
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"; |