From 82a3ce521115ce5803bb73f4849d1e66a319ee27 Mon Sep 17 00:00:00 2001 From: Jitka Plesnikova Date: Wed, 23 May 2018 15:56:47 +0200 Subject: [PATCH] Upgrade to 2.20 --- lib/App/Cpan.pm | 52 +++++++++++++++++++++------- lib/CPAN.pm | 21 ++++++++---- lib/CPAN/Distribution.pm | 89 +++++++++++++++++++++++++++++++++++++----------- lib/CPAN/FTP.pm | 38 ++++++++++++++------- lib/CPAN/FirstTime.pm | 6 ++-- lib/CPAN/Shell.pm | 4 +-- 6 files changed, 156 insertions(+), 54 deletions(-) diff --git a/lib/App/Cpan.pm b/lib/App/Cpan.pm index 3ddcbe8..8754912 100644 --- a/lib/App/Cpan.pm +++ b/lib/App/Cpan.pm @@ -6,7 +6,7 @@ use vars qw($VERSION); use if $] < 5.008 => 'IO::Scalar'; -$VERSION = '1.66'; +$VERSION = '1.67'; =head1 NAME @@ -545,7 +545,13 @@ package Local::Null::Logger; # hide from PAUSE sub new { bless \ my $x, $_[0] } -sub AUTOLOAD { 1 } +sub AUTOLOAD { + my $autoload = our $AUTOLOAD; + $autoload =~ s/.*://; + return if $autoload =~ /^(debug|trace)$/; + $CPAN::Frontend->mywarn(">($autoload): $_\n") + for split /[\r\n]+/, $_[1]; +} sub DESTROY { 1 } } @@ -566,7 +572,7 @@ sub _init_logger unless( $log4perl_loaded ) { - print STDERR "Loading internal null logger. Install Log::Log4perl for logging messages\n"; + print STDOUT "Loading internal logger. Log::Log4perl recommended for better logging\n"; $logger = Local::Null::Logger->new; return $logger; } @@ -625,6 +631,8 @@ sub _default # How do I handle exit codes for multiple arguments? my @errors = (); + $options->{x} or _disable_guessers(); + foreach my $arg ( @$args ) { # check the argument and perhaps capture typos @@ -1517,14 +1525,19 @@ sub _expand_module } my $guessers = [ - [ qw( Text::Levenshtein::XS distance 7 ) ], - [ qw( Text::Levenshtein::Damerau::XS xs_edistance 7 ) ], + [ qw( Text::Levenshtein::XS distance 7 1 ) ], + [ qw( Text::Levenshtein::Damerau::XS xs_edistance 7 1 ) ], - [ qw( Text::Levenshtein distance 7 ) ], - [ qw( Text::Levenshtein::Damerau::PP pp_edistance 7 ) ], + [ qw( Text::Levenshtein distance 7 1 ) ], + [ qw( Text::Levenshtein::Damerau::PP pp_edistance 7 1 ) ], ]; +sub _disable_guessers + { + $_->[-1] = 0 for @$guessers; + } + # for -x sub _guess_namespace { @@ -1553,25 +1566,40 @@ sub _list_all_namespaces { BEGIN { my $distance; +my $_threshold; +my $can_guess; +my $shown_help = 0; sub _guess_at_module_name { my( $target, $threshold ) = @_; unless( defined $distance ) { foreach my $try ( @$guessers ) { - my $can_guess = eval "require $try->[0]; 1" or next; + $can_guess = eval "require $try->[0]; 1" or next; + $try->[-1] or next; # disabled no strict 'refs'; $distance = \&{ join "::", @$try[0,1] }; $threshold ||= $try->[2]; } } + $_threshold ||= $threshold; unless( $distance ) { - my $modules = join ", ", map { $_->[0] } @$guessers; - substr $modules, rindex( $modules, ',' ), 1, ', and'; + unless( $shown_help ) { + my $modules = join ", ", map { $_->[0] } @$guessers; + substr $modules, rindex( $modules, ',' ), 1, ', and'; - $logger->info( "I can suggest names if you install one of $modules" ); + # Should this be colorized? + if( $can_guess ) { + $logger->info( "I can suggest names if you provide the -x option on invocation." ); + } + else { + $logger->info( "I can suggest names if you install one of $modules" ); + $logger->info( "and you provide the -x option on invocation." ); + } + $shown_help++; + } return; } @@ -1581,7 +1609,7 @@ sub _guess_at_module_name my %guesses; foreach my $guess ( @$modules ) { my $distance = $distance->( $target, $guess ); - next if $distance > $threshold; + next if $distance > $_threshold; $guesses{$guess} = $distance; } diff --git a/lib/CPAN.pm b/lib/CPAN.pm index 4f02850..1f69119 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -2,7 +2,7 @@ # vim: ts=4 sts=4 sw=4: use strict; package CPAN; -$CPAN::VERSION = '2.18'; +$CPAN::VERSION = '2.20'; $CPAN::VERSION =~ s/_//; # we need to run chdir all over and we would get at wrong libraries @@ -564,7 +564,10 @@ sub _yaml_loadfile { } } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) { local *FH; - open FH, $local_file or die "Could not open '$local_file': $!"; + unless (open FH, $local_file) { + $CPAN::Frontend->mywarn("Could not open '$local_file': $!"); + return +[]; + } local $/; my $ystream = ; eval { @yaml = $code->($ystream); }; @@ -856,11 +859,12 @@ this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your } my $sleep = 1; while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) { - if ($sleep>10) { - $CPAN::Frontend->mydie("Giving up\n"); + my $err = $! || "unknown error"; + if ($sleep>3) { + $CPAN::Frontend->mydie("Could not lock '$lockfile' with flock: $err; giving up\n"); } - $CPAN::Frontend->mysleep($sleep++); - $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n"); + $CPAN::Frontend->mysleep($sleep+=0.1); + $CPAN::Frontend->mywarn("Could not lock '$lockfile' with flock: $err; retrying\n"); } seek $fh, 0, 0; @@ -1038,6 +1042,11 @@ sub has_usable { 'CPAN::Meta::Requirements' => [ sub { + if (defined $CPAN::Meta::Requirements::VERSION + && CPAN::Version->vlt($CPAN::Meta::Requirements::VERSION, "2.120920") + ) { + delete $INC{"CPAN/Meta/Requirements.pm"}; + } require CPAN::Meta::Requirements; unless (CPAN::Version->vge(CPAN::Meta::Requirements->VERSION, 2.120920)) { for ("Will not use CPAN::Meta::Requirements, need version 2.120920\n") { diff --git a/lib/CPAN/Distribution.pm b/lib/CPAN/Distribution.pm index 64976eb..72101af 100644 --- a/lib/CPAN/Distribution.pm +++ b/lib/CPAN/Distribution.pm @@ -8,7 +8,7 @@ use CPAN::InfoObj; use File::Path (); @CPAN::Distribution::ISA = qw(CPAN::InfoObj); use vars qw($VERSION); -$VERSION = "2.18"; +$VERSION = "2.19"; # no prepare, because prepare is not a command on the shell command line # TODO: clear instance cache on reload @@ -660,8 +660,11 @@ sub satisfy_requires { my ($self) = @_; $self->debug("Entering satisfy_requires") if $CPAN::DEBUG; if (my @prereq = $self->unsat_prereq("later")) { - $self->debug("unsatisfied[@prereq]") if $CPAN::DEBUG; - $self->debug(@prereq) if $CPAN::DEBUG && @prereq; + if ($CPAN::DEBUG){ + require Data::Dumper; + my $prereq = Data::Dumper->new(\@prereq)->Terse(1)->Indent(0)->Dump; + $self->debug("unsatisfied[$prereq]"); + } if ($prereq[0][0] eq "perl") { my $need = "requires perl '$prereq[0][1]'"; my $id = $self->pretty_id; @@ -1717,13 +1720,10 @@ sub isa_perl { my($self) = @_; my $file = File::Basename::basename($self->id); if ($file =~ m{ ^ perl - -? - (5) - ([._-]) ( - \d{3}(_[0-4][0-9])? + -5\.\d+\.\d+ | - \d+\.\d+ + 5[._-]00[0-5](_[0-4][0-9])? ) \.tar[._-](?:gz|bz2) (?!\n)\Z @@ -1982,7 +1982,12 @@ sub prepare { } } elsif ( $self->_should_report('pl') ) { - ($output, $ret) = CPAN::Reporter::record_command($system); + ($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"); + return $self->goodbye("$system -- NOT OK"); + } CPAN::Reporter::grade_PL( $self, $system, $output, $ret ); } else { @@ -2084,7 +2089,7 @@ is part of the perl-%s distribution. To install that, you need to run $self->called_for, $self->isa_perl, $self->called_for, - $self->id, + $self->pretty_id, )); $self->{make} = CPAN::Distrostatus->new("NO isa perl"); $CPAN::Frontend->mysleep(1); @@ -2610,9 +2615,19 @@ sub _make_install_make_command { sub is_locally_optional { my($self, $prereq_pm, $prereq) = @_; $prereq_pm ||= $self->{prereq_pm}; - exists $prereq_pm->{opt_requires}{$prereq} - || - exists $prereq_pm->{opt_build_requires}{$prereq}; + my($nmo,$opt); + for my $rt (qw(requires build_requires)) { + if (exists $prereq_pm->{$rt}{$prereq}) { + # rt 121914 + $nmo ||= $CPAN::META->instance("CPAN::Module",$prereq); + my $av = $nmo->available_version; + return 0 if !$av || CPAN::Version->vlt($av,$prereq_pm->{$rt}{$prereq}); + } + if (exists $prereq_pm->{"opt_$rt"}{$prereq}) { + $opt = 1; + } + } + return $opt||0; } #-> sub CPAN::Distribution::follow_prereqs ; @@ -2761,8 +2776,29 @@ sub _feature_depends { sub prereqs_for_slot { my($self,$slot) = @_; my($prereq_pm); - $CPAN::META->has_usable("CPAN::Meta::Requirements") - or die "CPAN::Meta::Requirements not available"; + unless ($CPAN::META->has_usable("CPAN::Meta::Requirements")) { + my $whynot = "not available"; + if (defined $CPAN::Meta::Requirements::VERSION) { + $whynot = "version $CPAN::Meta::Requirements::VERSION not sufficient"; + } + $CPAN::Frontend->mywarn("CPAN::Meta::Requirements $whynot\n"); + my $before = ""; + if ($self->{CALLED_FOR}){ + if ($self->{CALLED_FOR} =~ + /^( + CPAN::Meta::Requirements + |version + |parent + |ExtUtils::MakeMaker + |Test::Harness + )$/x) { + $CPAN::Frontend->mywarn("Setting requirements to nil as a workaround\n"); + return; + } + $before = " before $self->{CALLED_FOR}"; + } + $CPAN::Frontend->mydie("Please install CPAN::Meta::Requirements manually$before"); + } my $merged = CPAN::Meta::Requirements->new; my $prefs_depends = $self->prefs->{depends}||{}; my $feature_depends = $self->_feature_depends(); @@ -2825,8 +2861,10 @@ sub unsat_prereq { my($self,$slot) = @_; my($merged_hash,$prereq_pm) = $self->prereqs_for_slot($slot); my(@need); - $CPAN::META->has_usable("CPAN::Meta::Requirements") - or die "CPAN::Meta::Requirements not available"; + unless ($CPAN::META->has_usable("CPAN::Meta::Requirements")) { + $CPAN::Frontend->mywarn("CPAN::Meta::Requirements not available, please install as soon as possible, trying to continue with severly limited capabilities\n"); + return; + } my $merged = CPAN::Meta::Requirements->from_string_hash($merged_hash); my @merged = sort $merged->required_modules; CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG; @@ -3047,6 +3085,10 @@ sub unsat_prereq { } # here need to flag as optional for recommends/suggests # -- xdg, 2012-04-01 + $self->debug(sprintf "%s manadory?[%s]", + $self->pretty_id, + $self->{mandatory}) + if $CPAN::DEBUG; my $optional = !$self->{mandatory} || $self->is_locally_optional($prereq_pm, $need_module); push @need, [$need_module,$needed_as,$optional]; @@ -3965,7 +4007,15 @@ sub install { 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($pipe) = FileHandle->new("$system $stderr |") || Carp::croak("Can't execute $system: $!"); + my($pipe) = FileHandle->new("$system $stderr |"); + unless ($pipe) { + $CPAN::Frontend->mywarn("Can't execute $system: $!"); + $self->introduce_myself; + $self->{install} = CPAN::Distrostatus->new("NO"); + $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); + delete $self->{force_update}; + return; + } my($makeout) = ""; while (<$pipe>) { print $_; # intentionally NOT use Frontend->myprint because it @@ -3980,7 +4030,8 @@ sub install { $CPAN::Frontend->myprint(" $system -- OK\n"); $CPAN::META->is_installed($self->{build_dir}); $self->{install} = CPAN::Distrostatus->new("YES"); - if ($CPAN::Config->{'cleanup_after_install'}) { + if ($CPAN::Config->{'cleanup_after_install'} + && ! $self->is_dot_dist) { 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}); diff --git a/lib/CPAN/FTP.pm b/lib/CPAN/FTP.pm index a43ea02..6d9800e 100644 --- a/lib/CPAN/FTP.pm +++ b/lib/CPAN/FTP.pm @@ -3,6 +3,7 @@ package CPAN::FTP; use strict; +use Errno (); use Fcntl qw(:flock); use File::Basename qw(dirname); use File::Path qw(mkpath); @@ -14,7 +15,20 @@ use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod); use vars qw( $VERSION ); -$VERSION = "5.5008"; +$VERSION = "5.5011"; + +sub _plus_append_open { + my($fh, $file) = @_; + my $parent_dir = dirname $file; + mkpath $parent_dir; + my($cnt); + until (open $fh, "+>>$file") { + next if $! == 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; + } +} #-> sub CPAN::FTP::ftp_statistics # if they want to rewrite, they need to pass in a filehandle @@ -28,8 +42,7 @@ sub _ftp_statistics { $fh ||= FileHandle->new; my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml"); - mkpath dirname $file; - open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!"); + _plus_append_open($fh,$file); my $sleep = 1; my $waitstart; while (!CPAN::_flock($fh, $locktype|LOCK_NB)) { @@ -41,13 +54,11 @@ sub _ftp_statistics { sleep($sleep); # this sleep must not be overridden; # Frontend->mysleep with AUTOMATED_TESTING has # provoked complete lock contention on my NFS - if ($sleep <= 3) { - $sleep+=0.33; - } elsif ($sleep <= 6) { - $sleep+=0.11; + if ($sleep <= 6) { + $sleep+=0.5; } else { # retry to get a fresh handle. If it is NFS and the handle is stale, we will never get an flock - open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!"); + _plus_append_open($fh, $file); } } my $stats = eval { CPAN->_yaml_loadfile($file); }; @@ -60,8 +71,11 @@ sub _ftp_statistics { } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") { my $time = time; my $to = "$file.$time"; - $CPAN::Frontend->myprint("Error reading '$file': $@\nStashing away as '$to' to prevent further interruptions. You may want to remove that file later.\n"); - rename $file, $to or $CPAN::Frontend->mydie("Could not rename: $!"); + $CPAN::Frontend->mywarn("Error reading '$file': $@ + Trying to stash it away as '$to' to prevent further interruptions. + You may want to remove that file later.\n"); + # may fail because somebody else has moved it away in the meantime: + rename $file, $to or $CPAN::Frontend->mywarn("Could not rename '$file' to '$to': $!\n"); return; } } else { @@ -139,7 +153,7 @@ sub _add_to_statistics { unlink($sfile) if ($^O eq 'MSWin32' or $^O eq 'os2'); _copy_stat($sfile, "$sfile.$$") if -e $sfile; rename "$sfile.$$", $sfile - or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n"); + or $CPAN::Frontend->mywarn("Could not rename '$sfile.$$' to '$sfile': $!\nGiving up\n"); } } @@ -555,7 +569,7 @@ sub hostdleasy { #called from hostdlxxx my($ro_url); HOSTEASY: for $ro_url (@$host_seq) { $self->_set_attempt($stats,"dleasy",$ro_url); - my $url .= "$ro_url$file"; + my $url = "$ro_url$file"; $self->debug("localizing perlish[$url]") if $CPAN::DEBUG; if ($url =~ /^file:/) { my $l; diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm index 531c115..49fa8ab 100644 --- a/lib/CPAN/FirstTime.pm +++ b/lib/CPAN/FirstTime.pm @@ -10,7 +10,7 @@ use File::Path (); use File::Spec (); use CPAN::Mirrors (); use vars qw($VERSION $auto_config); -$VERSION = "5.5310"; +$VERSION = "5.5311"; =head1 NAME @@ -439,7 +439,7 @@ Randomize parameter generally be installed except in resource constrained environments. When this policy is true, recommended modules will be included with required modules. -Included recommended modules? +Include recommended modules? =item scan_cache @@ -489,7 +489,7 @@ Show all individual modules that have a $VERSION of zero? dependencies provide enhanced operation. When this policy is true, suggested modules will be included with required modules. -Included suggested modules? +Include suggested modules? =item tar_verbosity diff --git a/lib/CPAN/Shell.pm b/lib/CPAN/Shell.pm index ab2f07e..423131c 100644 --- a/lib/CPAN/Shell.pm +++ b/lib/CPAN/Shell.pm @@ -47,7 +47,7 @@ use vars qw( "CPAN/Tarzip.pm", "CPAN/Version.pm", ); -$VERSION = "5.5006"; +$VERSION = "5.5007"; # record the initial timestamp for reload. $reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo }; @CPAN::Shell::ISA = qw(CPAN::Debug); @@ -1023,7 +1023,7 @@ CPAN_VERSION: %s %s $need{$module->id}++; } unless (%need) { - if ($what eq "u") { + if (!@expand || $what eq "u") { $CPAN::Frontend->myprint("No modules found for @args\n"); } elsif ($what eq "r") { $CPAN::Frontend->myprint("All modules are up to date for @args\n"); -- 2.14.3