In perl.git, the branch blead has been updated <https://perl5.git.perl.org/perl.git/commitdiff/5cf88abdca2d5d3d5c7adb953cb5f971f3c4539a?hp=ee45064db75af4283d61e5733ddcc5c7eb87e2d4>
- Log ----------------------------------------------------------------- commit 5cf88abdca2d5d3d5c7adb953cb5f971f3c4539a Author: Andreas Koenig <[email protected]> Date: Thu Jun 13 19:04:47 2019 +0000 [PATCH] Updates CPAN.pm to ANDK/CPAN-2.27-TRIAL2.tar.gz 2019-06-09 k <[email protected]> * release 2.27-TRIAL2 * bugfix: omit the new POSIX::setsid call and the waitpid with WNOHANG on Windows * bugfix: the signalhandler has to kill the new process group spawned for running the tests * adding the README file that was generated during the release of 2.27-TRIAL 2019-05-31 k <[email protected]> * release 2.27-TRIAL * two new options to protect against accidental downgrades: allow_installing_outdated_dists and allow_installing_module_downgrades * two new options to tune the automatic determination of the nearest peers: urllist_ping_external and urllist_ping_verbose; NOTE: this feature was developed during the Perl Toolchain Summit 2019 in Marlow; thanks to the sponsors: Booking.com, cPanel, MaxMind, FastMail, ZipRecruiter, Cogendo, Elastic, OpenCage Data, Perl Services, Zoopla, Archer Education, OpusVL, Oetiker+Partner, SureVoIP, YEF * reveal the size of PERL5LIB in diagnostic output * new semantics for parameter ftpstats_size: setting to '0' or lower, disables download statistics * bugfix: under certain circumstances, failing dependencies via recommends and suggests could abort a build; this is now fixed * bugfix: protect bundle processing against unavailable bundle files and missing build directories * bugfix: fix broken permissions after untar * bugfix: protect against exceptions from unzip * bugfix: add one level of fork+setsid for testing to prevent that a test can kill the process group that CPAN.pm is running in. Learned from experience with testing VIZDOM/DBD-JDBC-0.71.tar.gz * fix plugins: all early returns from all methods, that are accessible for plugins, now call the post* plugins * new question answered in the FAQ: "How can I switch to sudo instead of local::lib" (thanks to Amos Bird for asking the question on irc) * plenty of new and updated distroprefs documents, among which are some important ones to prevent Module::AutoInstall from switching to CPANPLUS and taking over (and harming) the build commit d2ece0ba72dfad1ecde95093c98e71b716988eb4 Author: Karen Etheridge <[email protected]> Date: Wed Jun 19 22:00:23 2019 -0700 ignore unwanted files copied from cpan repository ..and the distribution directories cannot be ignored; t/porting/podcheck.t will look inside them. commit cc26ac41e38507c4017a0546e5e7e14413b038ad Author: Karen Etheridge <[email protected]> Date: Wed Jun 19 21:59:11 2019 -0700 commit (possibly outdated?) TODO file from cpan repository commit 19ae68a28b049e881f6e8fe4fc1222181c9b0860 Author: Karen Etheridge <[email protected]> Date: Wed Jun 19 21:12:11 2019 -0700 whitespace changes only commit ae2a00c52756c58dcbaaa7ac525d709126ffd80c Author: Karen Etheridge <[email protected]> Date: Wed Jun 19 20:53:47 2019 -0700 bump reference date in cross-compilation docs commit 2004604722b372d693ca2c64628dbf67be50033b Author: Karen Etheridge <[email protected]> Date: Wed Jun 19 19:58:36 2019 -0700 whitespace changes only ----------------------------------------------------------------------- Summary of changes: AUTHORS | 2 +- INSTALL | 2 +- Porting/Maintainers.pl | 2 +- autodoc.pl | 118 ++++++------- cpan/CPAN/lib/CPAN.pm | 77 ++++++++- cpan/CPAN/lib/CPAN/Bundle.pm | 15 +- cpan/CPAN/lib/CPAN/Distribution.pm | 339 ++++++++++++++++++++++++++++++++---- cpan/CPAN/lib/CPAN/FTP.pm | 19 +- cpan/CPAN/lib/CPAN/FirstTime.pm | 77 ++++++++- cpan/CPAN/lib/CPAN/HandleConfig.pm | 10 +- cpan/CPAN/lib/CPAN/Mirrors.pm | 119 +++++++++---- cpan/CPAN/scripts/cpan | 7 +- dist/Devel-PPPort/.gitignore | 5 +- dist/Devel-PPPort/TODO | 346 +++++++++++++++++++++++++++++++++++++ 14 files changed, 978 insertions(+), 160 deletions(-) create mode 100644 dist/Devel-PPPort/TODO diff --git a/AUTHORS b/AUTHORS index c920d52e96..da9ff89189 100644 --- a/AUTHORS +++ b/AUTHORS @@ -1100,7 +1100,7 @@ Russel O'Connor <[email protected]> Russell Fulton <[email protected]> Russell Mosemann <[email protected]> Ryan Herbert <[email protected]> -Ryan Voots <[email protected]> +Ryan Voots <[email protected]> Salvador Fandiño <[email protected]> Salvador Ortiz Garcia <[email protected]> Sam Kimbrel <[email protected]> diff --git a/INSTALL b/INSTALL index 296e1aded5..5fb9636f8a 100644 --- a/INSTALL +++ b/INSTALL @@ -1806,7 +1806,7 @@ to avoid the BIND. Perl can be cross-compiled. It is just not trivial, cross-compilation rarely is. Perl is routinely cross-compiled for several platforms: as of -January 2014, these include Android, Blackberry 10, +June 2019, these include Android, Blackberry 10, ARM Linux, and Solaris. Previous versions of Perl also provided support for Open Zaurus, Symbian, and the IBM OS/400, but it's unknown if those ports are still functional. diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index a087d05404..c3d11dd168 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -253,7 +253,7 @@ use File::Glob qw(:case); }, 'CPAN' => { - 'DISTRIBUTION' => 'ANDK/CPAN-2.26.tar.gz', + 'DISTRIBUTION' => 'ANDK/CPAN-2.27-TRIAL2.tar.gz', 'FILES' => q[cpan/CPAN], 'EXCLUDED' => [ qr{^distroprefs/}, diff --git a/autodoc.pl b/autodoc.pl index 421d8de900..919da5e063 100644 --- a/autodoc.pl +++ b/autodoc.pl @@ -45,11 +45,11 @@ require './regen/embed_lib.pl'; my %docs; my %funcflags; my %macro = ( - ax => 1, - items => 1, - ix => 1, - svtype => 1, - ); + ax => 1, + items => 1, + ix => 1, + svtype => 1, + ); my %missing; my $curheader = "Unknown section"; @@ -63,17 +63,17 @@ sub autodoc ($$) { # parse a file and extract documentation info FUNC: while (defined($in = $get_next_line->())) { - if ($in =~ /^#\s*define\s+([A-Za-z_][A-Za-z_0-9]+)\(/ && - ($file ne 'embed.h' || $file ne 'proto.h')) { - $macro{$1} = $file; - next FUNC; - } + if ($in =~ /^#\s*define\s+([A-Za-z_][A-Za-z_0-9]+)\(/ && + ($file ne 'embed.h' || $file ne 'proto.h')) { + $macro{$1} = $file; + next FUNC; + } if ($in=~ /^=head1 (.*)/) { $curheader = $1; # If the next non-space line begins with a word char, then it is # the start of heading-ldevel documentation. - if (defined($doc = $get_next_line->())) { + if (defined($doc = $get_next_line->())) { # Skip over empty lines while ($doc =~ /^\s+$/) { if (! defined($doc = $get_next_line->())) { @@ -106,66 +106,66 @@ HDR_DOC: } next FUNC; } - if ($in =~ /^=for\s+apidoc\s+(.*?)\s*\n/) { - my $proto_in_file = $1; - my $proto = $proto_in_file; - $proto = "||$proto" unless $proto =~ /\|/; - my($flags, $ret, $name, @args) = split /\s*\|\s*/, $proto; + if ($in =~ /^=for\s+apidoc\s+(.*?)\s*\n/) { + my $proto_in_file = $1; + my $proto = $proto_in_file; + $proto = "||$proto" unless $proto =~ /\|/; + my($flags, $ret, $name, @args) = split /\s*\|\s*/, $proto; warn ("'$name' not \\w+ in '$proto_in_file' in $file") if $flags !~ /N/ && $name !~ / ^ [_[:alpha:]] \w* $ /x; - my $docs = ""; + my $docs = ""; DOC: - while (defined($doc = $get_next_line->())) { + while (defined($doc = $get_next_line->())) { # Other pod commands are considered part of the current # function's docs, so can have lists, etc. last DOC if $doc =~ /^=(cut|for\s+apidoc|head)/; - if ($doc =~ m:^\*/$:) { - warn "=cut missing? $file:$line:$doc";; - last DOC; + if ($doc =~ m:^\*/$:) { + warn "=cut missing? $file:$line:$doc";; + last DOC; } - $docs .= $doc; - } - $docs = "\n$docs" if $docs and $docs !~ /^\n/; + $docs .= $doc; + } + $docs = "\n$docs" if $docs and $docs !~ /^\n/; - # If the entry is also in embed.fnc, it should be defined + # If the entry is also in embed.fnc, it should be defined # completely there, but not here - my $embed_docref = delete $funcflags{$name}; - if ($embed_docref and %$embed_docref) { + my $embed_docref = delete $funcflags{$name}; + if ($embed_docref and %$embed_docref) { warn "embed.fnc entry overrides redundant information in" . " '$proto_in_file' in $file" if $flags || $ret || @args; $flags = $embed_docref->{'flags'}; $ret = $embed_docref->{'retval'}; - @args = @{$embed_docref->{args}}; - } else { - $missing{$name} = $file; - } + @args = @{$embed_docref->{args}}; + } else { + $missing{$name} = $file; + } my $inline_where = $flags =~ /A/ ? 'api' : 'guts'; - if (exists $docs{$inline_where}{$curheader}{$name}) { + if (exists $docs{$inline_where}{$curheader}{$name}) { warn "$0: duplicate API entry for '$name' in $inline_where/$curheader\n"; next; } - $docs{$inline_where}{$curheader}{$name} - = [$flags, $docs, $ret, $file, @args]; + $docs{$inline_where}{$curheader}{$name} + = [$flags, $docs, $ret, $file, @args]; # Create a special entry with an empty-string name for the # heading-level documentation. - if (defined $header_doc) { + if (defined $header_doc) { $docs{$inline_where}{$curheader}{""} = $header_doc; undef $header_doc; } - if (defined $doc) { - if ($doc =~ /^=(?:for|head)/) { - $in = $doc; - redo FUNC; - } - } else { - warn "$file:$line:$in"; - } - } + if (defined $doc) { + if ($doc =~ /^=(?:for|head)/) { + $in = $doc; + redo FUNC; + } + } else { + warn "$file:$line:$in"; + } + } } } @@ -188,7 +188,7 @@ removed without notice.\n\n$docs" if $flags =~ /x/; my $p = $flags =~ /p/ && $flags =~ /o/ && $flags !~ /M/; $docs .= "NOTE: the perl_ form of this function is deprecated.\n\n" - if $flags =~ /O/; + if $flags =~ /O/; if ($p) { $docs .= "NOTE: this function must be explicitly called as Perl_$name"; $docs .= " with an aTHX_ parameter" if $flags !~ /T/; @@ -199,7 +199,7 @@ removed without notice.\n\n$docs" if $flags =~ /x/; if ($flags =~ /U/) { # no usage warn("U and s flags are incompatible") if $flags =~ /s/; - # nothing + # nothing } else { if ($flags =~ /n/) { # no args warn("n flag without m") unless $flags =~ /m/; @@ -271,15 +271,15 @@ sub output { s/^\|//gm for $header, $footer; my $fh = open_new("pod/$podname.pod", undef, - {by => "$0 extracting documentation", + {by => "$0 extracting documentation", from => 'the C source files'}, 1); print $fh $header; my $key; for $key (sort sort_helper keys %$dochash) { - my $section = $dochash->{$key}; - print $fh "\n=head1 $key\n\n"; + my $section = $dochash->{$key}; + print $fh "\n=head1 $key\n\n"; # Output any heading-level documentation and delete so won't get in # the way later @@ -287,12 +287,12 @@ sub output { print $fh $section->{""} . "\n"; delete $section->{""}; } - print $fh "=over 8\n\n"; + print $fh "=over 8\n\n"; - for my $key (sort sort_helper keys %$section) { - docout($fh, $key, $section->{$key}); - } - print $fh "\n=back\n"; + for my $key (sort sort_helper keys %$section) { + docout($fh, $key, $section->{$key}); + } + print $fh "\n=back\n"; } if (@$missing) { @@ -335,10 +335,10 @@ foreach (@{(setup_embed())[0]}) { s/\b(?:NN|NULLOK)\b\s+//g for @args; $funcflags{$func} = { - flags => $flags, - retval => $retval, - args => \@args, - }; + flags => $flags, + retval => $retval, + args => \@args, + }; } # glob() picks up docs from extra .c or .h files that may be in unclean @@ -463,7 +463,7 @@ output('perlintern', <<'END', $docs{guts}, \@missing_guts, <<'END'); |=head1 NAME | |perlintern - autogenerated documentation of purely B<internal> -| Perl functions +|Perl functions | |=head1 DESCRIPTION |X<internal Perl functions> X<interpreter functions> diff --git a/cpan/CPAN/lib/CPAN.pm b/cpan/CPAN/lib/CPAN.pm index a25a5fad7b..2d87f47f8b 100644 --- a/cpan/CPAN/lib/CPAN.pm +++ b/cpan/CPAN/lib/CPAN.pm @@ -2,7 +2,7 @@ # vim: ts=4 sts=4 sw=4: use strict; package CPAN; -$CPAN::VERSION = '2.26'; +$CPAN::VERSION = '2.27'; $CPAN::VERSION =~ s/_//; # we need to run chdir all over and we would get at wrong libraries @@ -1468,11 +1468,12 @@ sub set_perl5lib { $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; } else { my $cnt = keys %{$self->{is_tested}}; - $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ". - "$cnt build dirs to PERL5LIB; ". - "for '$for'\n" + my $newenv = join $Config::Config{path_sep}, @dirs, @env; + $CPAN::Frontend->optprint('perl5lib', sprintf ("Prepending blib/arch and blib/lib of ". + "%d build dirs to PERL5LIB, reaching size %d; ". + "for '%s'\n", $cnt, length($newenv), $for) ); - $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; + $ENV{PERL5LIB} = $newenv; } }} @@ -2144,6 +2145,12 @@ where WORD is any valid config variable or a regular expression. The following keys in the hash reference $CPAN::Config are currently defined: + allow_installing_module_downgrades + allow or disallow installing module downgrades + allow_installing_outdated_dists + allow or disallow installing modules that are + indexed in the cpan index pointing to a distro + with a higher distro-version number applypatch path to external prg auto_commit commit all changes to config variables to disk build_cache size of cache for directories to build modules @@ -2262,6 +2269,10 @@ currently defined: CPAN::Reporter history) unzip location of external program unzip urllist arrayref to nearby CPAN sites (or equivalent locations) + urllist_ping_external + use external ping command when autoselecting mirrors + urllist_ping_verbose + increase verbosity when autoselecting mirrors use_prompt_default set PERL_MM_USE_DEFAULT for configure/make/test/install use_sqlite use CPAN::SQLite for metadata storage (fast and lean) username your username if you CPAN server wants one @@ -2407,6 +2418,43 @@ both modules declared as C<requires> and those declared as C<build_requires> are treated alike. By setting to C<ask/yes> or C<ask/no>, CPAN.pm asks the user and sets the default accordingly. +=head2 Configuration of the allow_installing_* parameters + +The C<allow_installing_*> parameters are evaluated during +the C<make> phase. If set to C<yes>, they allow the testing and the installation of +the current distro and otherwise have no effect. If set to C<no>, they +may abort the build (preventing testing and installing), depending on the contents of the +C<blib/> directory. The C<blib/> directory is the directory that holds +all the files that would usually be installed in the C<install> phase. + +C<allow_installing_outdated_dists> compares the C<blib/> directory with the CPAN index. +If it finds something there that belongs, according to the index, to a different +dist, it aborts the current build. + +C<allow_installing_module_downgrades> compares the C<blib/> directory +with already installed modules, actually their version numbers, as +determined by ExtUtils::MakeMaker or equivalent. If a to-be-installed +module would downgrade an already installed module, the current build +is aborted. + +An interesting twist occurs when a distroprefs document demands the +installation of an outdated dist via goto while +C<allow_installing_outdated_dists> forbids it. Without additional +provisions, this would let the C<allow_installing_outdated_dists> +win and the distroprefs lose. So the proper arrangement in such a case +is to write a second distroprefs document for the distro that C<goto> +points to and overrule the C<cpanconfig> there. E.g.: + + --- + match: + distribution: "^MAUKE/Keyword-Simple-0.04.tar.gz" + goto: "MAUKE/Keyword-Simple-0.03.tar.gz" + --- + match: + distribution: "^MAUKE/Keyword-Simple-0.03.tar.gz" + cpanconfig: + allow_installing_outdated_dists: yes + =head2 Configuration for individual distributions (I<Distroprefs>) (B<Note:> This feature has been introduced in CPAN.pm 1.8854) @@ -3946,6 +3994,25 @@ directory) or exit the CPAN shell, respectively. If you never start up the CPAN shell, you probably also have to clean up the build directory yourself. +=item 19) + +How can I switch to sudo instead of local::lib? + +The following 5 environment veriables need to be reset to the previous +values: PATH, PERL5LIB, PERL_LOCAL_LIB_ROOT, PERL_MB_OPT, PERL_MM_OPT; +and these two CPAN.pm config variables must be reconfigured: +make_install_make_command and mbuild_install_build_command. The five +env variables have probably been overwritten in your $HOME/.bashrc or +some equivalent. You either find them there and delete their traces +and logout/login or you override them temporarily, depending on your +exact desire. The two cpanpm config variables can be set with: + + o conf init /install_.*_command/ + +probably followed by + + o conf commit + =back =head1 COMPATIBILITY diff --git a/cpan/CPAN/lib/CPAN/Bundle.pm b/cpan/CPAN/lib/CPAN/Bundle.pm index 9270502914..99c95ac4d6 100644 --- a/cpan/CPAN/lib/CPAN/Bundle.pm +++ b/cpan/CPAN/lib/CPAN/Bundle.pm @@ -8,7 +8,7 @@ use CPAN::Module; use vars qw( $VERSION ); -$VERSION = "5.5004"; +$VERSION = "5.5005"; sub look { my $self = shift; @@ -87,11 +87,11 @@ sub contains { # Try to get at it in the cpan directory $self->debug("no inst_file") if $CPAN::DEBUG; my $cpan_file; - $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless + $CPAN::Frontend->mydie("I don't know a bundle with ID '$id'\n") unless $cpan_file = $self->cpan_file; if ($cpan_file eq "N/A") { - $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN. - Maybe stale symlink? Maybe removed during session? Giving up.\n"); + $CPAN::Frontend->mywarn("Bundle '$id' not found on disk and not on CPAN. Maybe stale symlink? Maybe removed during session?\n"); + return; } my $dist = $CPAN::META->instance('CPAN::Distribution', $self->cpan_file); @@ -103,7 +103,12 @@ sub contains { @me = split /::/, $self->id; $me[-1] .= ".pm"; $me = File::Spec->catfile(@me); - $from = $self->find_bundle_file($dist->{build_dir},join('/',@me)); + my $build_dir; + unless ($build_dir = $dist->{build_dir}) { + $CPAN::Frontend->mywarn("Warning: cannot determine bundle content without a build_dir.\n"); + return; + } + $from = $self->find_bundle_file($build_dir,join('/',@me)); $to = File::Spec->catfile($todir,$me); File::Path::mkpath(File::Basename::dirname($to)); File::Copy::copy($from, $to) diff --git a/cpan/CPAN/lib/CPAN/Distribution.pm b/cpan/CPAN/lib/CPAN/Distribution.pm index ea637c865b..3412108539 100644 --- a/cpan/CPAN/lib/CPAN/Distribution.pm +++ b/cpan/CPAN/lib/CPAN/Distribution.pm @@ -6,9 +6,12 @@ use Cwd qw(chdir); use CPAN::Distroprefs; use CPAN::InfoObj; use File::Path (); +use POSIX ":sys_wait_h"; @CPAN::Distribution::ISA = qw(CPAN::InfoObj); use vars qw($VERSION); -$VERSION = "2.24"; +$VERSION = "2.27"; + +my $run_allow_installing_within_test = 1; # boolean; either in test or in install, there is no third option # no prepare, because prepare is not a command on the shell command line # TODO: clear instance cache on reload @@ -377,10 +380,12 @@ sub get { $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG; if (my $goto = $self->prefs->{goto}) { + $self->post_get(); return $self->goto($goto); } if ( defined( my $sc = $self->shortcut_get) ) { + $self->post_get(); return $sc; } @@ -399,15 +404,22 @@ sub get { # is already checked in shortcut_get() -- xdg, 2012-04-05 unless ($self->{build_dir} && -d $self->{build_dir}) { $self->get_file_onto_local_disk; - return if $CPAN::Signal; + if ($CPAN::Signal){ + $self->post_get(); + return; + } $self->check_integrity; - return if $CPAN::Signal; + if ($CPAN::Signal){ + $self->post_get(); + return; + } (my $packagedir,$local_file) = $self->run_preps_on_packagedir; # XXX why is this check here? -- xdg, 2012-04-08 if (exists $self->{writemakefile} && ref $self->{writemakefile} && $self->{writemakefile}->can("failed") && $self->{writemakefile}->failed) { # + $self->post_get(); return; } $packagedir ||= $self->{build_dir}; @@ -419,9 +431,13 @@ sub get { # a $CPAN::Signal check -- xdg, 2012-04-05 if ($CPAN::Signal) { $self->safe_chdir($sub_wd); + $self->post_get(); + return; + } + unless ($self->patch){ + $self->post_get(); return; } - return unless $self->patch; $self->store_persistent_state; $self->post_get(); @@ -540,9 +556,10 @@ See also http://rt.cpan.org/Ticket/Display.html?id=38932\n";); if (@readdir == 1 && -d $readdir[0]) { $tdir_base = $readdir[0]; $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]); + my($mode) = (stat $from_dir)[2]; + chmod $mode | 00755, $from_dir; # JONATHAN/Math-Calculus-TaylorSeries-0.1.tar.gz has 0644 my $dh2; unless ($dh2 = DirHandle->new($from_dir)) { - my($mode) = (stat $from_dir)[2]; my $why = sprintf ( "Couldn't opendir '%s', mode '%o': %s", @@ -565,10 +582,6 @@ See also http://rt.cpan.org/Ticket/Display.html?id=38932\n";); $from_dir = File::Spec->curdir; @dirents = @readdir; } - eval { File::Path::mkpath $builddir; }; - if ($@) { - $CPAN::Frontend->mydie("Cannot create directory $builddir: $@"); - } my $packagedir; my $eexist = ($CPAN::META->has_usable("Errno") && defined &Errno::EEXIST) ? &Errno::EEXIST : undef; @@ -583,6 +596,8 @@ See also http://rt.cpan.org/Ticket/Display.html?id=38932\n";); my $f; for $f (@dirents) { # is already without "." and ".." my $from = File::Spec->catfile($from_dir,$f); + my($mode) = (stat $from)[2]; + chmod $mode | 00755, $from if -d $from; # OTTO/Pod-Trial-LinkImg-0.005.tgz my $to = File::Spec->catfile($packagedir,$f); unless (File::Copy::move($from,$to)) { my $err = $!; @@ -1228,10 +1243,10 @@ sub untar_me { sub unzip_me { my($self,$ct) = @_; $self->{archived} = "zip"; - if ($ct->unzip()) { + if (eval { $ct->unzip() }) { $self->{unwrapped} = CPAN::Distrostatus->new("YES"); } else { - $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed"); + $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed during unzip"); } return; } @@ -1846,7 +1861,9 @@ sub prepare { ? $ENV{PERL5LIB} : ($ENV{PERLLIB} || ""); local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; - local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # prepare + local $ENV{PERL_USE_UNSAFE_INC} = + exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC} + ? $ENV{PERL_USE_UNSAFE_INC} : 1; # prepare $CPAN::META->set_perl5lib; local $ENV{MAKEFLAGS}; # protect us from outer make calls @@ -2081,11 +2098,13 @@ sub make { $self->pre_make(); if (exists $self->{cleanup_after_install_done}) { + $self->post_make(); return $self->get; } $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG; if (my $goto = $self->prefs->{goto}) { + $self->post_make(); return $self->goto($goto); } # Emergency brake if they said install Pippi and get newest perl @@ -2122,19 +2141,24 @@ is part of the perl-%s distribution. To install that, you need to run )); $self->{make} = CPAN::Distrostatus->new("NO isa perl"); $CPAN::Frontend->mysleep(1); + $self->post_make(); return; } } - $self->prepare - or return; + unless ($self->prepare){ + $self->post_make(); + return; + } if ( defined( my $sc = $self->shortcut_make) ) { + $self->post_make(); return $sc; } if ($CPAN::Signal) { delete $self->{force_update}; + $self->post_make(); return; } @@ -2143,6 +2167,7 @@ is part of the perl-%s distribution. To install that, you need to run unless (chdir $builddir) { $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!"); + $self->post_make(); return; } @@ -2152,17 +2177,21 @@ is part of the perl-%s distribution. To install that, you need to run ? $ENV{PERL5LIB} : ($ENV{PERLLIB} || ""); local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; - local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # make + local $ENV{PERL_USE_UNSAFE_INC} = + exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC} + ? $ENV{PERL_USE_UNSAFE_INC} : 1; # make $CPAN::META->set_perl5lib; local $ENV{MAKEFLAGS}; # protect us from outer make calls if ($CPAN::Signal) { delete $self->{force_update}; + $self->post_make(); return; } if ($^O eq 'MacOS') { Mac::BuildTools::make($self); + $self->post_make(); return; } @@ -2173,16 +2202,23 @@ is part of the perl-%s distribution. To install that, you need to run } local @ENV{keys %env} = values %env; my $satisfied = eval { $self->satisfy_requires }; - return $self->goodbye($@) if $@; - return unless $satisfied ; + if ($@) { + return $self->goodbye($@); + } + unless ($satisfied){ + $self->post_make(); + return; + } if ($CPAN::Signal) { delete $self->{force_update}; + $self->post_make(); return; } # need to chdir again, because $self->satisfy_requires might change the directory unless (chdir $builddir) { $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!"); + $self->post_make(); return; } @@ -2816,12 +2852,16 @@ sub prereqs_for_slot { if ($self->{CALLED_FOR} =~ /^( CPAN::Meta::Requirements + |CPAN::DistnameInfo |version |parent |ExtUtils::MakeMaker |Test::Harness )$/x) { - $CPAN::Frontend->mywarn("Setting requirements to nil as a workaround\n"); + $CPAN::Frontend->mywarn("Please install CPAN::Meta::Requirements ". + "as soon as possible; it is needed for a reliable operation of ". + "the cpan shell; setting requirements to nil for '$1' for now ". + "to prevent deadlock during bootstrapping\n"); return; } $before = " before $self->{CALLED_FOR}"; @@ -3555,24 +3595,30 @@ sub test { $self->pre_test(); if (exists $self->{cleanup_after_install_done}) { + $self->post_test(); return $self->make; } $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG; if (my $goto = $self->prefs->{goto}) { + $self->post_test(); return $self->goto($goto); } - $self->make - or return; + unless ($self->make){ + $self->post_test(); + return; + } if ( defined( my $sc = $self->shortcut_test ) ) { + $self->post_test(); return $sc; } if ($CPAN::Signal) { - delete $self->{force_update}; - return; + delete $self->{force_update}; + $self->post_test(); + return; } # warn "XDEBUG: checking for notest: $self->{notest} $self"; my $make = $self->{modulebuild} ? "Build" : "make"; @@ -3582,12 +3628,26 @@ sub test { : ($ENV{PERLLIB} || ""); local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; - local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # test + local $ENV{PERL_USE_UNSAFE_INC} = + exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC} + ? $ENV{PERL_USE_UNSAFE_INC} : 1; # test $CPAN::META->set_perl5lib; local $ENV{MAKEFLAGS}; # protect us from outer make calls local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default}; local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default}; + if ($run_allow_installing_within_test) { + my($allow_installing, $why) = $self->_allow_installing; + if (! $allow_installing) { + $CPAN::Frontend->mywarn("Testing/Installation stopped: $why\n"); + $self->introduce_myself; + $self->{make_test} = CPAN::Distrostatus->new("NO -- testing/installation stopped due $why"); + $CPAN::Frontend->mywarn(" [testing] -- NOT OK\n"); + delete $self->{force_update}; + $self->post_test(); + return; + } + } $CPAN::Frontend->myprint(sprintf "Running %s test for %s\n", $make, $self->pretty_id); my $builddir = $self->dir or @@ -3595,6 +3655,7 @@ sub test { unless (chdir $builddir) { $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!"); + $self->post_test(); return; } @@ -3603,6 +3664,7 @@ sub test { if ($^O eq 'MacOS') { Mac::BuildTools::make_test($self); + $self->post_test(); return; } @@ -3614,9 +3676,10 @@ sub test { # Test::Harness 3.0 self-tests, so that should be 'unless # installing Test::Harness' unless ($self->id eq $thm->distribution->id) { - $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only + $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n}); $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old"); + $self->post_test(); return; } } @@ -3638,12 +3701,14 @@ sub test { $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME}); } $CPAN::Frontend->myprint("Found prior test report -- OK\n"); + $self->post_test(); return; } elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) { $self->{make_test} = CPAN::Distrostatus->new("NO"); $self->{badtestcnt}++; $CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n"); + $self->post_test(); return; } } @@ -3687,18 +3752,45 @@ sub test { "testing without\n"); } } - if ($want_expect) { - if ($self->_should_report('test')) { - $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ". - "not supported when distroprefs specify ". - "an interactive test\n"); + + FORK: { + my $pid = fork; + if (! defined $pid) { # contention + warn "Contention '$!', sleeping 2"; + sleep 2; + redo FORK; + } elsif ($pid) { # parent + if ($^O eq "MSWin32") { + wait; + } else { + SUPERVISE: while (waitpid($pid, WNOHANG) <= 0) { + if ($CPAN::Signal) { + kill 9, -$pid; + } + sleep 1; + } + } + $tests_ok = !$?; + } else { # child + POSIX::setsid() unless $^O eq "MSWin32"; + my $c_ok; + $|=1; + if ($want_expect) { + if ($self->_should_report('test')) { + $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ". + "not supported when distroprefs specify ". + "an interactive test\n"); + } + $c_ok = $self->_run_via_expect($system,'test',$expect_model) == 0; + } elsif ( $self->_should_report('test') ) { + $c_ok = CPAN::Reporter::test($self, $system); + } else { + $c_ok = system($system) == 0; + } + exit !$c_ok; } - $tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0; - } elsif ( $self->_should_report('test') ) { - $tests_ok = CPAN::Reporter::test($self, $system); - } else { - $tests_ok = system($system) == 0; - } + } # FORK + $self->introduce_myself; my $but = $self->_make_test_illuminate_prereqs(); if ( $tests_ok ) { @@ -3706,6 +3798,7 @@ sub test { $CPAN::Frontend->mywarn("Tests succeeded but $but\n"); $self->{make_test} = CPAN::Distrostatus->new("NO $but"); $self->store_persistent_state; + $self->post_test(); return $self->goodbye("[dependencies] -- NA"); } $CPAN::Frontend->myprint(" $system -- OK\n"); @@ -3723,6 +3816,8 @@ sub test { $self->{make_test} = CPAN::Distrostatus->new( "NO but failure ignored because 'force' in effect" ); + } elsif ($CPAN::Signal) { + $self->{make_test} = CPAN::Distrostatus->new("NO -- Interrupted"); } else { $self->{make_test} = CPAN::Distrostatus->new("NO"); } @@ -3772,7 +3867,7 @@ sub _make_test_illuminate_prereqs { if $CPAN::DEBUG; } else { push @prereq, $m - if $m_obj->{mandatory}; + unless $self->is_locally_optional(undef, $m); } } my $but; @@ -4095,7 +4190,9 @@ sub install { : ($ENV{PERLLIB} || ""); local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; - local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # install + local $ENV{PERL_USE_UNSAFE_INC} = + exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC} + ? $ENV{PERL_USE_UNSAFE_INC} : 1; # install $CPAN::META->set_perl5lib; local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default}; local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default}; @@ -4106,6 +4203,18 @@ sub install { } local @ENV{keys %$install_env} = values %$install_env if $install_env; + if (! $run_allow_installing_within_test) { + my($allow_installing, $why) = $self->_allow_installing; + if (! $allow_installing) { + $CPAN::Frontend->mywarn("Installation stopped: $why\n"); + $self->introduce_myself; + $self->{install} = CPAN::Distrostatus->new("NO -- installation stopped due $why"); + $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); + delete $self->{force_update}; + $self->post_install(); + return; + } + } my($pipe) = FileHandle->new("$system $stderr |"); unless ($pipe) { $CPAN::Frontend->mywarn("Can't execute $system: $!"); @@ -4177,6 +4286,162 @@ sub install { return !! $close_ok; } +sub blib_pm_walk { + my @queue = grep { -e $_ } File::Spec->catdir("blib","lib"), File::Spec->catdir("blib","arch"); + return sub { + LOOP: { + if (@queue) { + my $file = shift @queue; + if (-d $file) { + my $dh; + opendir $dh, $file or next; + my @newfiles = map { + my @ret; + my $maybedir = File::Spec->catdir($file, $_); + if (-d $maybedir) { + unless (File::Spec->catdir("blib","arch","auto") eq $maybedir) { + # prune the blib/arch/auto directory, no pm files there + @ret = $maybedir; + } + } elsif (/\.pm$/) { + my $mustbefile = File::Spec->catfile($file, $_); + if (-f $mustbefile) { + @ret = $mustbefile; + } + } + @ret; + } grep { + $_ ne "." + && $_ ne ".." + } readdir $dh; + push @queue, @newfiles; + redo LOOP; + } else { + return $file; + } + } else { + return; + } + } + }; +} + +sub _allow_installing { + my($self) = @_; + my $id = my $pretty_id = $self->pretty_id; + if ($self->{CALLED_FOR}) { + $id .= " (called for $self->{CALLED_FOR})"; + } + my $allow_down = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_module_downgrades}); + $allow_down ||= "ask/yes"; + my $allow_outdd = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_outdated_dists}); + $allow_outdd ||= "ask/yes"; + return 1 if + $allow_down eq "yes" + && $allow_outdd eq "yes"; + if (($allow_outdd ne "yes") && ! $CPAN::META->has_inst('CPAN::DistnameInfo')) { + return 1 if grep { $_ eq 'CPAN::DistnameInfo'} $self->containsmods; + if ($allow_outdd ne "yes") { + $CPAN::Frontend->mywarn("The current configuration of allow_installing_outdated_dists is '$allow_outdd', but for this option we would need 'CPAN::DistnameInfo' installed. Please install 'CPAN::DistnameInfo' as soon as possible. As long as we are not equipped with 'CPAN::DistnameInfo' this option does not take effect\n"); + $allow_outdd = "yes"; + } + } + return 1 if + $allow_down eq "yes" + && $allow_outdd eq "yes"; + my($dist_version, $dist_dist); + if ($allow_outdd ne "yes"){ + my $dni = CPAN::DistnameInfo->new($pretty_id); + $dist_version = $dni->version; + $dist_dist = $dni->dist; + } + my $iterator = blib_pm_walk(); + my(@down,@outdd); + while (my $file = $iterator->()) { + my $version = CPAN::Module->parse_version($file); + my($volume, $directories, $pmfile) = File::Spec->splitpath( $file ); + my @dirs = File::Spec->splitdir( $directories ); + my(@blib_plus1) = splice @dirs, 0, 2; + my($pmpath) = File::Spec->catfile(grep { length($_) } @dirs, $pmfile); + unless ($allow_down eq "yes") { + if (my $inst_file = $self->_file_in_path($pmpath, \@INC)) { + my $inst_version = CPAN::Module->parse_version($inst_file); + my $cmp = CPAN::Version->vcmp($version, $inst_version); + if ($cmp) { + if ($cmp < 0) { + push @down, { pmpath => $pmpath, version => $version, inst_version => $inst_version }; + } + } + if (@down) { + my $why = "allow_installing_module_downgrades: $id contains downgrading module(s) (e.g. '$down[0]{pmpath}' would downgrade installed '$down[0]{inst_version}' to '$down[0]{version}')"; + if (my($default) = $allow_down =~ m|^ask/(.+)|) { + $default = "yes" unless $default =~ /^(y|n)/i; + my $answer = CPAN::Shell::colorable_makemaker_prompt + ("$why. Do you want to allow installing it?", + $default, "colorize_warn"); + $allow_down = $answer =~ /^\s*y/i ? "yes" : "no"; + } + if ($allow_down eq "no") { + return (0, $why); + } + } + } + } + unless ($allow_outdd eq "yes") { + my @pmpath = (@dirs, $pmfile); + $pmpath[-1] =~ s/\.pm$//; + my $mo = CPAN::Shell->expand("Module",join "::", grep { length($_) } @pmpath); + if ($mo) { + my $cpan_version = $mo->cpan_version; + my $is_lower = CPAN::Version->vlt($version, $cpan_version); + my $other_dist; + if (my $mo_dist = $mo->distribution) { + $other_dist = $mo_dist->pretty_id; + my $dni = CPAN::DistnameInfo->new($other_dist); + if ($dni->dist eq $dist_dist){ + if (CPAN::Version->vgt($dni->version, $dist_version)) { + push @outdd, { + pmpath => $pmpath, + cpan_path => $dni->pathname, + dist_version => $dni->version, + dist_dist => $dni->dist, + }; + } + } + } + } + if (@outdd && $allow_outdd ne "yes") { + my $why = "allow_installing_outdated_dists: $id contains module(s) that are indexed on the CPAN with a different distro: (e.g. '$outdd[0]{pmpath}' is indexed with '$outdd[0]{cpan_path}')"; + if ($outdd[0]{dist_dist} eq $dist_dist) { + $why .= ", and this has a higher distribution-version, i.e. version '$outdd[0]{dist_version}' is higher than '$dist_version')"; + } + if (my($default) = $allow_outdd =~ m|^ask/(.+)|) { + $default = "yes" unless $default =~ /^(y|n)/i; + my $answer = CPAN::Shell::colorable_makemaker_prompt + ("$why. Do you want to allow installing it?", + $default, "colorize_warn"); + $allow_outdd = $answer =~ /^\s*y/i ? "yes" : "no"; + } + if ($allow_outdd eq "no") { + return (0, $why); + } + } + } + } + return 1; +} + +sub _file_in_path { # similar to CPAN::Module::_file_in_path + my($self,$pmpath,$incpath) = @_; + my($dir,@packpath); + foreach $dir (@$incpath) { + my $pmfile = File::Spec->catfile($dir,$pmpath); + if (-f $pmfile) { + return $pmfile; + } + } + return; +} sub introduce_myself { my($self) = @_; $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id)); diff --git a/cpan/CPAN/lib/CPAN/FTP.pm b/cpan/CPAN/lib/CPAN/FTP.pm index 6d9800e31b..1688a118e4 100644 --- a/cpan/CPAN/lib/CPAN/FTP.pm +++ b/cpan/CPAN/lib/CPAN/FTP.pm @@ -15,7 +15,7 @@ use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod); use vars qw( $VERSION ); -$VERSION = "5.5011"; +$VERSION = "5.5012"; sub _plus_append_open { my($fh, $file) = @_; @@ -23,7 +23,7 @@ sub _plus_append_open { mkpath $parent_dir; my($cnt); until (open $fh, "+>>$file") { - next if $! == Errno::EAGAIN; # don't increment on EAGAIN + next if exists &Errno::EAGAIN && $! == &Errno::EAGAIN; # don't increment on EAGAIN $CPAN::Frontend->mydie("Could not open '$file' after 10000 tries: $!") if ++$cnt > 100000; sleep 0.0001; mkpath $parent_dir; @@ -34,6 +34,8 @@ sub _plus_append_open { # if they want to rewrite, they need to pass in a filehandle sub _ftp_statistics { my($self,$fh) = @_; + my $ftpstats_size = $CPAN::Config->{ftpstats_size}; + return if defined $ftpstats_size && $ftpstats_size <= 0; my $locktype = $fh ? LOCK_EX : LOCK_SH; # XXX On Windows flock() implements mandatory locking, so we can # XXX only use shared locking to still allow _yaml_load_file() to @@ -120,18 +122,23 @@ sub _add_to_statistics { my @debug; @debug = $time if $sdebug; my $fullstats = $self->_ftp_statistics($fh); - close $fh; + close $fh if $fh && defined(fileno($fh)); $fullstats->{history} ||= []; push @debug, scalar @{$fullstats->{history}} if $sdebug; push @debug, time if $sdebug; push @{$fullstats->{history}}, $stats; # YAML.pm 0.62 is unacceptably slow with 999; # YAML::Syck 0.82 has no noticable performance problem with 999; - my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99; + my $ftpstats_size = $CPAN::Config->{ftpstats_size}; + $ftpstats_size = 99 unless defined $ftpstats_size; my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14; while ( - @{$fullstats->{history}} > $ftpstats_size - || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period + @{$fullstats->{history} || []} + && + ( + @{$fullstats->{history}} > $ftpstats_size + || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period + ) ) { shift @{$fullstats->{history}} } diff --git a/cpan/CPAN/lib/CPAN/FirstTime.pm b/cpan/CPAN/lib/CPAN/FirstTime.pm index ae2f662261..af4a6d7759 100644 --- a/cpan/CPAN/lib/CPAN/FirstTime.pm +++ b/cpan/CPAN/lib/CPAN/FirstTime.pm @@ -11,7 +11,7 @@ use File::Spec (); use CPAN::Mirrors (); use CPAN::Version (); use vars qw($VERSION $auto_config); -$VERSION = "5.5313"; +$VERSION = "5.5314"; =head1 NAME @@ -38,6 +38,34 @@ my @podpara = split /\n\n/, <<'=back'; =over 2 +=item allow_installing_module_downgrades + +The CPAN shell can watch the C<blib/> directories that are built up +before running C<make test> to determine whether the current +distribution will end up with modules being overwritten with decreasing module version numbers. It +can then let the build of this distro fail when it discovers a +downgrade. + +Do you want to allow installing distros with decreasing module +versions compared to what you have installed (yes, no, ask/yes, +ask/no)? + +=item allow_installing_outdated_dists + +The CPAN shell can watch the C<blib/> directories that are built up +before running C<make test> to determine whether the current +distribution contains modules that are indexed with a distro with a +higher distro-version number than the current one. It can +then let the build of this distro fail when it would not represent the +most up-to-date version of the distro. + +Note: choosing anyhing but 'yes' for this option will need +Devel::DistnameInfo being installed for taking effect. + +Do you want to allow installing distros that are not indexed as the +highest distro-version for all contained modules (yes, no, ask/yes, +ask/no)? + =item auto_commit Normally CPAN.pm keeps config variables in memory and changes need to @@ -193,7 +221,8 @@ How many days shall we keep statistics about downloads? =item ftpstats_size Statistics about downloads are truncated by size and period -simultaneously. +simultaneously. Setting this to zero or negative disables download +statistics. How many items shall we keep in the statistics about downloads? @@ -568,6 +597,23 @@ regardless of the history using "force". Do you want to rely on the test report history (yes/no)? +=item urllist_ping_external + +When automatic selection of the nearest cpan mirrors is performed, +turn on the use of the external ping via Net::Ping::External. This is +recommended in the case the local network has a transparent proxy. + +Do you want to use the external ping command when autoselecting +mirrors? + +=item urllist_ping_verbose + +When automatic selection of the nearest cpan mirrors is performed, +this option can be used to turn on verbosity during the selection +process. + +Do you want to see verbosity turned on when autoselecting mirrors? + =item use_prompt_default When this is true, CPAN will set PERL_MM_USE_DEFAULT to a true @@ -1089,6 +1135,14 @@ sub init { my_dflt_prompt(mbuild_install_arg => "", $matcher); + for my $o (qw( + allow_installing_outdated_dists + allow_installing_module_downgrades + )) { + my_prompt_loop($o => 'ask/no', $matcher, + 'yes|no|ask/yes|ask/no'); + } + # #== use_prompt_default # @@ -1264,6 +1318,12 @@ sub init { # Allow matching but don't show during manual config if ($matcher) { + if ("urllist_ping_external" =~ $matcher) { + my_yn_prompt(urllist_ping_external => 0, $matcher); + } + if ("urllist_ping_verbose" =~ $matcher) { + my_yn_prompt(urllist_ping_verbose => 0, $matcher); + } if ("randomize_urllist" =~ $matcher) { my_dflt_prompt(randomize_urllist => 0, $matcher); } @@ -1679,7 +1739,6 @@ sub my_yn_prompt { my $default; defined($default = $CPAN::Config->{$item}) or $default = $dflt; - # $DB::single = 1; if (!$auto_config && (!$m || $item =~ /$m/)) { if (my $intro = $prompts{$item . "_intro"}) { $CPAN::Frontend->myprint($intro); @@ -1917,17 +1976,25 @@ sub auto_mirrored_by { my $mirrors = CPAN::Mirrors->new($local); my $cnt = 0; + my $callback_was_active = 0; my @best = $mirrors->best_mirrors( how_many => 3, callback => sub { + $callback_was_active++; $CPAN::Frontend->myprint("."); if ($cnt++>60) { $cnt=0; $CPAN::Frontend->myprint("\n"); } }, + $CPAN::Config->{urllist_ping_external} ? (external_ping => 1) : (), + $CPAN::Config->{urllist_ping_verbose} ? (verbose => 1) : (), ); - my $urllist = [ map { $_->http } @best ]; + my $urllist = [ + map { $_->http } + grep { $_ && ref $_ && $_->can('http') } + @best + ]; push @$urllist, grep { /^file:/ } @{$CPAN::Config->{urllist}}; - $CPAN::Frontend->myprint(" done!\n\n"); + $CPAN::Frontend->myprint(" done!\n\n") if $callback_was_active; return $urllist } diff --git a/cpan/CPAN/lib/CPAN/HandleConfig.pm b/cpan/CPAN/lib/CPAN/HandleConfig.pm index 6cc12af667..e24a969c11 100644 --- a/cpan/CPAN/lib/CPAN/HandleConfig.pm +++ b/cpan/CPAN/lib/CPAN/HandleConfig.pm @@ -12,7 +12,7 @@ CPAN::HandleConfig - internal configuration handling for CPAN.pm =cut -$VERSION = "5.5009"; # see also CPAN::Config::VERSION at end of file +$VERSION = "5.5011"; # see also CPAN::Config::VERSION at end of file %can = ( commit => "Commit changes to disk", @@ -33,6 +33,8 @@ $VERSION = "5.5009"; # see also CPAN::Config::VERSION at end of file %keys = map { $_ => undef } ( + "allow_installing_module_downgrades", + "allow_installing_outdated_dists", "applypatch", "auto_commit", "build_cache", @@ -112,6 +114,8 @@ $VERSION = "5.5009"; # see also CPAN::Config::VERSION at end of file "trust_test_report_history", "unzip", "urllist", + "urllist_ping_verbose", + "urllist_ping_external", "use_prompt_default", "use_sqlite", "username", @@ -124,6 +128,8 @@ $VERSION = "5.5009"; # see also CPAN::Config::VERSION at end of file my %prefssupport = map { $_ => 1 } ( + "allow_installing_module_downgrades", + "allow_installing_outdated_dists", "build_requires_install_policy", "check_sigs", "make", @@ -770,7 +776,7 @@ sub prefs_lookup { use strict; use vars qw($AUTOLOAD $VERSION); - $VERSION = "5.5008"; + $VERSION = "5.5011"; # formerly CPAN::HandleConfig was known as CPAN::Config sub AUTOLOAD { ## no critic diff --git a/cpan/CPAN/lib/CPAN/Mirrors.pm b/cpan/CPAN/lib/CPAN/Mirrors.pm index 29bb7216ff..721ead2a85 100644 --- a/cpan/CPAN/lib/CPAN/Mirrors.pm +++ b/cpan/CPAN/lib/CPAN/Mirrors.pm @@ -19,7 +19,7 @@ CPAN::Mirrors - Get CPAN mirror information and select a fast one my( $m ) = @_; printf "%s = %s\n", $m->hostname, $m->rtt }; - $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback ); + $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback, %args ); @mirrors = sort { $a->rtt <=> $b->rtt } @mirrors; @@ -34,12 +34,13 @@ CPAN::Mirrors - Get CPAN mirror information and select a fast one package CPAN::Mirrors; use strict; use vars qw($VERSION $urllist $silent); -$VERSION = "2.21"; +$VERSION = "2.27"; use Carp; use FileHandle; use Fcntl ":flock"; use Net::Ping (); +use CPAN::Version; =item new( LOCAL_FILE_NAME ) @@ -82,7 +83,7 @@ Return a list of continents based on those defined in F<MIRRORED.BY>. sub continents { my ($self) = @_; - return sort keys %{$self->{geography}}; + return sort keys %{$self->{geography} || {}}; } =item countries( [CONTINENTS] ) @@ -99,7 +100,7 @@ sub countries { @continents = $self->continents unless @continents; my @countries; for my $c (@continents) { - push @countries, sort keys %{ $self->{geography}{$c} }; + push @countries, sort keys %{ $self->{geography}{$c} || {} }; } return @countries; } @@ -165,22 +166,25 @@ dynamic DNS to give a close mirror. =cut -sub default_mirror { 'http://www.cpan.org/' } +sub default_mirror { + CPAN::Mirrored::By->new({ http => 'http://www.cpan.org/'}); +} =item best_mirrors C<best_mirrors> checks for the best mirrors based on the list of continents you pass, or, without that, all continents, as defined by C<CPAN::Mirrored::By>. It pings each mirror, up to the value of -C<how_many>. In list context, it returns up to C<how_many> mirror. +C<how_many>. In list context, it returns up to C<how_many> mirrors. In scalar context, it returns the single best mirror. Arguments - how_many - the number of mirrors to return. Default: 1 - callback - a callback for find_best_continents - verbose - true or false on all the whining and moaning. Default: false - continents - an array ref of the continents to check + how_many - the number of mirrors to return. Default: 1 + callback - a callback for find_best_continents + verbose - true or false on all the whining and moaning. Default: false + continents - an array ref of the continents to check + external_ping - if true, use external ping via Net::Ping::External. Default: false If you don't specify the continents, C<best_mirrors> calls C<find_best_continents> to get the list of continents to check. @@ -188,6 +192,9 @@ C<find_best_continents> to get the list of continents to check. If you don't have L<Net::Ping> v2.13 or later, needed for timings, this returns the default mirror. +C<external_ping> should be set and then C<Net::Ping::External> needs +to be installed, if the local network has a transparent proxy. + =cut sub best_mirrors { @@ -197,10 +204,12 @@ sub best_mirrors { my $verbose = defined $args{verbose} ? $args{verbose} : 0; my $continents = $args{continents} || []; $continents = [$continents] unless ref $continents; + $args{external_ping} = 0 unless defined $args{external_ping}; + my $external_ping = $args{external_ping}; # Old Net::Ping did not do timings at all my $min_version = '2.13'; - unless( Net::Ping->VERSION gt $min_version ) { + unless( CPAN::Version->vgt(Net::Ping->VERSION, $min_version) ) { carp sprintf "Net::Ping version is %s (< %s). Returning %s", Net::Ping->VERSION, $min_version, $self->default_mirror; return $self->default_mirror; @@ -211,9 +220,10 @@ sub best_mirrors { if ( ! @$continents ) { print "Searching for the best continent ...\n" if $verbose; my @best_continents = $self->find_best_continents( - seen => $seen, - verbose => $verbose, - callback => $callback, + seen => $seen, + verbose => $verbose, + callback => $callback, + external_ping => $external_ping, ); # Only add enough continents to find enough mirrors @@ -225,12 +235,18 @@ sub best_mirrors { } } + return $self->default_mirror unless @$continents; print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose; my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] ); - my $timings = $self->get_mirrors_timings( $trial_mirrors, $seen, $callback ); - return [] unless @$timings; + my $timings = $self->get_mirrors_timings( + $trial_mirrors, + $seen, + $callback, + %args, + ); + return $self->default_mirror unless @$timings; $how_many = @$timings if $how_many > @$timings; @@ -268,7 +284,7 @@ sub get_n_random_mirrors_by_continents { \@long_list; } -=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK ); +=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK, %ARGS ); Pings the listed mirrors and returns a list of mirrors sorted in ascending ping times. @@ -286,7 +302,7 @@ ping. =cut sub get_mirrors_timings { - my( $self, $mirror_list, $seen, $callback ) = @_; + my( $self, $mirror_list, $seen, $callback, %args ) = @_; $seen = {} unless defined $seen; croak "The mirror list argument must be an array reference" @@ -302,8 +318,9 @@ sub get_mirrors_timings { next unless eval{ $m->http }; if( $self->_try_a_ping( $seen, $m, ) ) { - my $ping = $m->ping; + my $ping = $m->ping(%args); next unless defined $ping; + # printf "m %s ping %s\n", $m, $ping; push @$timings, $m; $callback->( $m ) if $callback; } @@ -367,20 +384,21 @@ value. sub find_best_continents { my ($self, %args) = @_; - $args{n} ||= 3; + $args{n} ||= 3; $args{verbose} = 0 unless defined $args{verbose}; $args{seen} = {} unless defined $args{seen}; croak "The seen argument must be a hash reference" unless ref $args{seen} eq ref {}; $args{ping_cache_limit} = 24 * 60 * 60 - unless defined $args{ping_cache_time}; + unless defined $args{ping_cache_limit}; croak "callback must be a subroutine" if( defined $args{callback} and ref $args{callback} ne ref sub {} ); my %medians; CONT: for my $c ( $self->continents ) { - print "Testing $c\n" if $args{verbose}; my @mirrors = $self->mirrors( $self->countries($c) ); + printf "Testing %s (%d mirrors)\n", $c, scalar @mirrors + if $args{verbose}; next CONT unless @mirrors; my $n = (@mirrors < $args{n}) ? @mirrors : $args{n}; @@ -389,11 +407,18 @@ sub find_best_continents { my $tries = 0; RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) { my $m = splice( @mirrors, int(rand(@mirrors)), 1 ); - if( $self->_try_a_ping( $args{seen}, $m, $args{ping_cache_limit} ) ) { - $self->get_mirrors_timings( [ $m ], $args{seen}, $args{callback} ); + if( $self->_try_a_ping( + $args{seen}, $m, $args{ping_cache_limit} + )) { + $self->get_mirrors_timings( + [ $m ], + $args{seen}, + $args{callback}, + %args, + ); next RANDOM unless defined $args{seen}{$m->hostname}->rtt; } - printf "\t%s -> %0.2f ms\n", + printf "(%s -> %0.2f ms)", $m->hostname, join ' ', 1000 * $args{seen}{$m->hostname}->rtt if $args{verbose}; @@ -409,8 +434,12 @@ sub find_best_continents { if ( $args{verbose} ) { print "Median result by continent:\n"; - for my $c ( @best_cont ) { - printf( " %4d ms %s\n", int($medians{$c}*1000+.5), $c ); + if ( @best_cont ) { + for my $c ( @best_cont ) { + printf( " %7.2f ms %s\n", $medians{$c}*1000, $c ); + } + } else { + print " **** No results found ****\n" } } @@ -421,12 +450,14 @@ sub find_best_continents { sub _try_a_ping { my ($self, $seen, $mirror, $ping_cache_limit ) = @_; - ( ! exists $seen->{$mirror->hostname} ) + ( ! exists $seen->{$mirror->hostname} or - ( ! defined $seen->{$mirror->hostname}->rtt - or - time - $seen->{$mirror->hostname}->rtt > $ping_cache_limit + or + ! defined $ping_cache_limit + or + time - $seen->{$mirror->hostname}->ping_time + > $ping_cache_limit ) } @@ -445,7 +476,13 @@ sub _get_median_ping_time { } }; - printf "\t-->median time: %0.2f ms\n", $median * 1000 if $verbose; + if ($verbose){ + if ($median) { + printf " => median time: %.2f ms\n", $median * 1000 + } else { + printf " => **** no median time ****\n"; + } + } return $median; } @@ -546,9 +583,17 @@ sub url { } sub ping { - my $self = shift; + my($self, %args) = @_; - my $ping = Net::Ping->new($^O eq 'VMS' ? 'icmp' : 'tcp', 1); + my $external_ping = $args{external_ping}; + if ($external_ping) { + eval { require Net::Ping::External } + or die "Net::Ping::External required to use external ping command"; + } + my $ping = Net::Ping->new( + $external_ping ? 'external' : $^O eq 'VMS' ? 'icmp' : 'tcp', + 1 + ); my ($proto) = $self->url =~ m{^([^:]+)}; my $port = $proto eq 'http' ? 80 : 21; return unless $port; @@ -561,7 +606,11 @@ sub ping { } $ping->hires(1) if $ping->can('hires'); - my ($alive,$rtt) = $ping->ping($self->hostname); + my ($alive,$rtt) = eval { $ping->ping($self->hostname); }; + my $verbose = $args{verbose}; + if ($verbose && !$alive) { + printf "(host %s not alive)", $self->hostname; + } $self->{rtt} = $alive ? $rtt : undef; $self->{ping_time} = time; diff --git a/cpan/CPAN/scripts/cpan b/cpan/CPAN/scripts/cpan index 0041b8ab20..4e900b0054 100644 --- a/cpan/CPAN/scripts/cpan +++ b/cpan/CPAN/scripts/cpan @@ -4,7 +4,12 @@ BEGIN { pop @INC if $INC[-1] eq '.' } use strict; use vars qw($VERSION); -use App::Cpan '1.64'; +use App::Cpan; +use CPAN::Version; +my $minver = '1.64'; +if ( CPAN::Version->vlt($App::Cpan::VERSION, $minver) ) { + warn "WARNING: your version of App::Cpan is $App::Cpan::VERSION while we would expect at least $minver"; +} $VERSION = '1.64'; my $rc = App::Cpan->run( @ARGV ); diff --git a/dist/Devel-PPPort/.gitignore b/dist/Devel-PPPort/.gitignore index 9f3cd26464..1cf54b9405 100644 --- a/dist/Devel-PPPort/.gitignore +++ b/dist/Devel-PPPort/.gitignore @@ -12,5 +12,6 @@ pm_to_blib /ppport.h /*.o PPPort.bs -/Devel-PPPort-*.tar.gz -/Devel-PPPort-*/ +/README +/README.md +/.travis.yml diff --git a/dist/Devel-PPPort/TODO b/dist/Devel-PPPort/TODO new file mode 100644 index 0000000000..a54a8c3e2d --- /dev/null +++ b/dist/Devel-PPPort/TODO @@ -0,0 +1,346 @@ +TODO: + +* > 3. In several cases, "perl ppport.h --copy=.new" output a new file in + > which the only change was the addition of "#include "ppport.h"". In each + > case, that actually wasn't necessary because the source file in question + > already #included another source file which #included ppport.h itself. + > Would it be possible for the analyzer to follow #include directives to + > spot cases like this? + + Uh, well, I guess it would be possible. But I have some concerns: + + 1. ppport.h is already too big. :-) + + 2. There is code in ppport.h to actually remove an + + #include "ppport.h" + + if it appears not to be needed. If it's not needed in your + included file, it might be dropped from there and moved to + the other file that included the first one. This would make + the logic much more complicated. + + 3. As ppport.h is configurable, it's not (always) a good idea + to put it into a file that's included from another file. + + I guess I'll have to think about this a little more. Maybe I can + come up with a fancy solution that doesn't increase the code size + too much. + + +* On 14/12/06, Nicholas Clark <[email protected]> wrote: + > On Thu, Dec 14, 2006 at 05:03:24AM +0100, Andreas J. Koenig wrote: + > + > > Params::Validate and Clone suffer from the same cold: + > + > The same patch will make both compile and pass tests. + > I'm wondering if it might be better to totally drop SVt_PBVM and let source + > code fail to compile. + + I don't think so. Because : + 1. your redefinition of SVt_PBVM is probably what most XS modules want + 2. anyway, if we remove it from the core, it might appear in Devel::PPPort :) + + +* maybe backport bytes_from_utf8() for 5.6.0 (or even before)? + +* check which of the following we need to support: + + amagic_generation + AMG_names + an + Argv + argvgv + argvoutgv + basetime + beginav + block_type + bodytarget + bufend + bufptr + check + chopset + Cmd + compcv + compiling + comppad + comppad_name + comppad_name_fill + copline + cop_seqmax + cryptseen + cshlen + cshname + curcop + curinterp + curpad + curpm + curstash + curstname + dbargs + DBgv + DBline + DBsignal + DBsingle + DBsub + DBtrace + debstash + debug + defgv + defoutgv + defstash + delaymagic + diehook + dirty + doextract + doswitches + do_undump + dowarn + egid + encoding + endav + envgv + errgv + error_count + errors + euid + eval_root + evalseq + eval_start + expect + fdpid + filemode + firstgv + fold + forkprocess + formfeed + formtarget + freq + generation + gensym + gid + hexdigit + hints + incgv + in_eval + in_my + inplace + lastfd + last_in_gv + last_lop + last_lop_op + lastscream + laststatval + laststype + last_uni + lex_brackets + lex_brackstack + lex_casemods + lex_casestack + lex_defer + lex_dojoin + lex_expect + lex_formbrack + lex_inpat + lex_inwhat + lex_op + lex_repl + lex_starts + lex_state + lex_stuff + lineary + linestr + localizing + main_cv + main_root + mainstack + main_start + markstack + markstack_max + markstack_ptr + max_intro_pending + maxo + maxscream + maxsysfd + min_intro_pending + minus_a + minus_c + minus_F + minus_l + minus_n + minus_p + multi_close + multi_end + multi_open + multi_start + na + nexttoke + nexttype + nextval + nice_chunk + nice_chunk_size + No + no_aelem + no_dir_func + no_func + no_mem + nomemok + no_modify + no_myglob + no_security + no_sock_func + no_symref + no_usym + no_wrongref + nrs + oldbufptr + oldname + oldoldbufptr + op + opargs + op_desc + op_mask + op_name + op_seq + origalen + origargc + origargv + origenviron + origfilename + osname + padix + padix_floor + pad_reset_pending + patchlevel + patleave + perldb + perl_destruct_level + pidstatus + ppaddr + preambleav + preambled + preprocess + profiledata + regdummy + regendp + regeol + reginput + regkind + reglastparen + regsize + regstartp + restartop + rs + rsfp + rsfp_filters + runops + savestack + savestack_ix + savestack_max + sawampersand + scopestack + scopestack_ix ... 104 lines suppressed ... -- Perl5 Master Repository
