diff options
Diffstat (limited to 'cpan/CPAN/lib/CPAN')
| -rw-r--r-- | cpan/CPAN/lib/CPAN/CacheMgr.pm | 1 | ||||
| -rw-r--r-- | cpan/CPAN/lib/CPAN/Distribution.pm | 109 | ||||
| -rw-r--r-- | cpan/CPAN/lib/CPAN/Distroprefs.pm | 8 | ||||
| -rw-r--r-- | cpan/CPAN/lib/CPAN/Exception/yaml_not_installed.pm | 50 | ||||
| -rw-r--r-- | cpan/CPAN/lib/CPAN/Exception/yaml_process_error.pm | 53 | ||||
| -rw-r--r-- | cpan/CPAN/lib/CPAN/FTP.pm | 12 | ||||
| -rw-r--r-- | cpan/CPAN/lib/CPAN/FirstTime.pm | 48 | ||||
| -rw-r--r-- | cpan/CPAN/lib/CPAN/HTTP/Client.pm | 6 | ||||
| -rw-r--r-- | cpan/CPAN/lib/CPAN/HandleConfig.pm | 22 | ||||
| -rw-r--r-- | cpan/CPAN/lib/CPAN/Index.pm | 12 | ||||
| -rw-r--r-- | cpan/CPAN/lib/CPAN/Mirrors.pm | 439 | ||||
| -rw-r--r-- | cpan/CPAN/lib/CPAN/Shell.pm | 9 |
12 files changed, 531 insertions, 238 deletions
diff --git a/cpan/CPAN/lib/CPAN/CacheMgr.pm b/cpan/CPAN/lib/CPAN/CacheMgr.pm index b9b4eeb32b..23e756e75b 100644 --- a/cpan/CPAN/lib/CPAN/CacheMgr.pm +++ b/cpan/CPAN/lib/CPAN/CacheMgr.pm @@ -49,6 +49,7 @@ sub tidyup { $self->_clean_cache($toremove); return if $CPAN::Signal; } + $self->{FIFO} = []; } #-> sub CPAN::CacheMgr::dir ; diff --git a/cpan/CPAN/lib/CPAN/Distribution.pm b/cpan/CPAN/lib/CPAN/Distribution.pm index b39e723fd2..32648ecc1f 100644 --- a/cpan/CPAN/lib/CPAN/Distribution.pm +++ b/cpan/CPAN/lib/CPAN/Distribution.pm @@ -158,7 +158,7 @@ sub tested_ok_but_not_installed { || $self->{install}->failed ) - ); + ); } @@ -584,7 +584,8 @@ EOF #-> sub CPAN::Distribution::pick_meta_file ; sub pick_meta_file { - my($self, $yaml) = @_; + my($self, $filter) = @_; + $filter = '.' unless defined $filter; my $build_dir; unless ($build_dir = $self->{build_dir}) { @@ -602,7 +603,7 @@ sub pick_meta_file { push @choices, 'META.json' if $has_cm; push @choices, 'META.yml' if $has_cm || $has_pcm; - for my $file ( @choices ) { + for my $file ( grep { /$filter/ } @choices ) { my $path = File::Spec->catdir( $build_dir, $file ); return $path if -f $path } @@ -740,7 +741,7 @@ sub choose_MM_or_MB { $prefer_installer = CPAN::HandleConfig->prefs_lookup( $self, q{prefer_installer} ); - # M::B <= 0.35 left a DATA handle open that + # M::B <= 0.35 left a DATA handle open that # causes problems upgrading M::B on Windows close *Module::Build::Version::DATA if fileno *Module::Build::Version::DATA; @@ -776,6 +777,12 @@ sub choose_MM_or_MB { sub store_persistent_state { my($self) = @_; my $dir = $self->{build_dir}; + unless (defined $dir && length $dir) { + my $id = $self->id; + $CPAN::Frontend->mywarnonce("build_dir of $id is not known, ". + "will not store persistent state\n"); + return; + } unless (File::Spec->canonpath(File::Basename::dirname($dir)) eq File::Spec->canonpath($CPAN::Config->{build_dir})) { $CPAN::Frontend->mywarnonce("Directory '$dir' not below $CPAN::Config->{build_dir}, ". @@ -858,7 +865,7 @@ sub try_download { } } my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches"); - $CPAN::Frontend->myprint("Going to apply $countedpatches:\n"); + $CPAN::Frontend->myprint("Applying $countedpatches:\n"); my $patches_dir = $CPAN::Config->{patches_dir}; for my $patch (@$patches) { if ($patches_dir && !File::Spec->file_name_is_absolute($patch)) { @@ -1844,7 +1851,7 @@ is part of the perl-%s distribution. To install that, you need to run delete $self->{force_update}; return; } - $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n"); + $CPAN::Frontend->myprint("\n CPAN.pm: Building ".$self->id."\n\n"); $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; if ($^O eq 'MacOS') { @@ -2843,8 +2850,7 @@ sub _fulfills_all_version_rqs { } #-> sub CPAN::Distribution::read_meta -# read any sort of meta files, return CPAN::Meta object if no errors and -# dynamic_config = 0 +# read any sort of meta files, return CPAN::Meta object if no errors sub read_meta { my($self) = @_; my $meta_file = $self->pick_meta_file @@ -2862,9 +2868,6 @@ sub read_meta { return if $eummv < 6.2501; } - # META/MYMETA is only authoritative if dynamic_config is false - return if $meta->dynamic_config; - return $meta; } @@ -2889,8 +2892,8 @@ sub read_yaml { if $CPAN::DEBUG; $self->debug($yaml) if $CPAN::DEBUG && $yaml; # MYMETA.yml is static and authoritative by definition - if ( $meta_file =~ /MYMETA\.yml/ ) { - return $yaml; + if ( $meta_file =~ /MYMETA\.yml/ ) { + return $yaml; } # META.yml is authoritative only if dynamic_config is defined and false if ( defined $yaml->{dynamic_config} && ! $yaml->{dynamic_config} ) { @@ -2903,7 +2906,7 @@ sub read_yaml { #-> sub CPAN::Distribution::configure_requires ; sub configure_requires { my($self) = @_; - return unless my $meta_file = $self->pick_meta_file; + return unless my $meta_file = $self->pick_meta_file('^META'); if (my $meta_obj = $self->read_meta) { my $prereqs = $meta_obj->effective_prereqs; my $cr = $prereqs->requirements_for(qw/configure requires/); @@ -2929,7 +2932,9 @@ sub prereq_pm { $self->{modulebuild}||"", ) if $CPAN::DEBUG; my($req,$breq); - if (my $meta_obj = $self->read_meta) { + my $meta_obj = $self->read_meta; + # META/MYMETA is only authoritative if dynamic_config is false + if ($meta_obj && ! $meta_obj->dynamic_config) { my $prereqs = $meta_obj->effective_prereqs; my $requires = $prereqs->requirements_for(qw/runtime requires/); my $build_requires = $prereqs->requirements_for(qw/build requires/); @@ -3168,7 +3173,7 @@ sub test { # bypass actual tests if "trust_test_report_history" and have a report my $have_tested_fcn; if ( $CPAN::Config->{trust_test_report_history} - && $CPAN::META->has_inst("CPAN::Reporter::History") + && $CPAN::META->has_inst("CPAN::Reporter::History") && ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) { if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) { # Do nothing if grade was DISCARD @@ -3288,43 +3293,43 @@ sub test { sub _make_test_illuminate_prereqs { my($self) = @_; - my @prereq; - - # local $CPAN::DEBUG = 16; # Distribution - for my $m (keys %{$self->{sponsored_mods}}) { - next unless $self->{sponsored_mods}{$m} > 0; - my $m_obj = CPAN::Shell->expand("Module",$m) or next; - # XXX we need available_version which reflects - # $ENV{PERL5LIB} so that already tested but not yet - # installed modules are counted. - my $available_version = $m_obj->available_version; - my $available_file = $m_obj->available_file; - if ($available_version && - !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m}) - ) { - CPAN->debug("m[$m] good enough available_version[$available_version]") - if $CPAN::DEBUG; - } elsif ($available_file - && ( - !$self->{prereq_pm}{$m} - || - $self->{prereq_pm}{$m} == 0 - ) - ) { - # lex Class::Accessor::Chained::Fast which has no $VERSION - CPAN->debug("m[$m] have available_file[$available_file]") - if $CPAN::DEBUG; - } else { - push @prereq, $m; - } - } + my @prereq; + + # local $CPAN::DEBUG = 16; # Distribution + for my $m (keys %{$self->{sponsored_mods}}) { + next unless $self->{sponsored_mods}{$m} > 0; + my $m_obj = CPAN::Shell->expand("Module",$m) or next; + # XXX we need available_version which reflects + # $ENV{PERL5LIB} so that already tested but not yet + # installed modules are counted. + my $available_version = $m_obj->available_version; + my $available_file = $m_obj->available_file; + if ($available_version && + !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m}) + ) { + CPAN->debug("m[$m] good enough available_version[$available_version]") + if $CPAN::DEBUG; + } elsif ($available_file + && ( + !$self->{prereq_pm}{$m} + || + $self->{prereq_pm}{$m} == 0 + ) + ) { + # lex Class::Accessor::Chained::Fast which has no $VERSION + CPAN->debug("m[$m] have available_file[$available_file]") + if $CPAN::DEBUG; + } else { + push @prereq, $m; + } + } my $but; - if (@prereq) { - my $cnt = @prereq; - my $which = join ",", @prereq; + if (@prereq) { + my $cnt = @prereq; + my $which = join ",", @prereq; $but = $cnt == 1 ? "one dependency not OK ($which)" : - "$cnt dependencies missing ($which)"; - } + "$cnt dependencies missing ($which)"; + } $but; } @@ -3670,7 +3675,7 @@ sub perldoc { $CPAN::Frontend->myprint(qq{ Function system("@args") returned status $estatus (wstat $wstatus) - }); + }); } } else { diff --git a/cpan/CPAN/lib/CPAN/Distroprefs.pm b/cpan/CPAN/lib/CPAN/Distroprefs.pm index e1be9cdf74..61c389ed2d 100644 --- a/cpan/CPAN/lib/CPAN/Distroprefs.pm +++ b/cpan/CPAN/lib/CPAN/Distroprefs.pm @@ -169,7 +169,7 @@ sub find { file => $_, ext => $ext, dir => $dir }); # copied from CPAN.pm; is this ever actually possible? - redo unless -f $result->abs; + redo unless -f $result->abs; my $load_method = $self->_load_method($loader, $result); my @prefs = eval { $self->$load_method($loader, $result) }; @@ -314,7 +314,7 @@ __END__ CPAN::Distroprefs -- read and match distroprefs -=head1 SYNOPSIS +=head1 SYNOPSIS use CPAN::Distroprefs; @@ -381,7 +381,7 @@ All results share some common attributes: C<success>, C<warning>, or C<fatal> -=head3 file +=head3 file the file from which these prefs were read, or to which this error refers (relative filename) @@ -413,7 +413,7 @@ Success results contain: an arrayref of CPAN::Distroprefs::Pref objects -=head1 PREFS +=head1 PREFS CPAN::Distroprefs::Pref objects represent individual distroprefs documents. They are constructed automatically as part of C<success> results from C<find()>. diff --git a/cpan/CPAN/lib/CPAN/Exception/yaml_not_installed.pm b/cpan/CPAN/lib/CPAN/Exception/yaml_not_installed.pm index e1259e5397..1e7fa83a53 100644 --- a/cpan/CPAN/lib/CPAN/Exception/yaml_not_installed.pm +++ b/cpan/CPAN/lib/CPAN/Exception/yaml_not_installed.pm @@ -20,54 +20,4 @@ sub as_string { "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n"; } -package CPAN::Exception::yaml_process_error; -use strict; -use overload '""' => "as_string"; - -use vars qw( - $VERSION -); -$VERSION = "5.5"; - - -sub new { - my($class,$module,$file,$during,$error) = @_; - # my $at = Carp::longmess(""); # XXX find something more beautiful - bless { module => $module, - file => $file, - during => $during, - error => $error, - # at => $at, - }, $class; -} - -sub as_string { - my($self) = shift; - if ($self->{during}) { - if ($self->{file}) { - if ($self->{module}) { - if ($self->{error}) { - return "Alert: While trying to '$self->{during}' YAML file\n". - " '$self->{file}'\n". - "with '$self->{module}' the following error was encountered:\n". - " $self->{error}\n"; - } else { - return "Alert: While trying to '$self->{during}' YAML file\n". - " '$self->{file}'\n". - "with '$self->{module}' some unknown error was encountered\n"; - } - } else { - return "Alert: While trying to '$self->{during}' YAML file\n". - " '$self->{file}'\n". - "some unknown error was encountered\n"; - } - } else { - return "Alert: While trying to '$self->{during}' some YAML file\n". - "some unknown error was encountered\n"; - } - } else { - return "Alert: unknown error encountered\n"; - } -} - 1; diff --git a/cpan/CPAN/lib/CPAN/Exception/yaml_process_error.pm b/cpan/CPAN/lib/CPAN/Exception/yaml_process_error.pm new file mode 100644 index 0000000000..ae8c14ebeb --- /dev/null +++ b/cpan/CPAN/lib/CPAN/Exception/yaml_process_error.pm @@ -0,0 +1,53 @@ +# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- +# vim: ts=4 sts=4 sw=4: +package CPAN::Exception::yaml_process_error; +use strict; +use overload '""' => "as_string"; + +use vars qw( + $VERSION +); +$VERSION = "5.5"; + + +sub new { + my($class,$module,$file,$during,$error) = @_; + # my $at = Carp::longmess(""); # XXX find something more beautiful + bless { module => $module, + file => $file, + during => $during, + error => $error, + # at => $at, + }, $class; +} + +sub as_string { + my($self) = shift; + if ($self->{during}) { + if ($self->{file}) { + if ($self->{module}) { + if ($self->{error}) { + return "Alert: While trying to '$self->{during}' YAML file\n". + " '$self->{file}'\n". + "with '$self->{module}' the following error was encountered:\n". + " $self->{error}\n"; + } else { + return "Alert: While trying to '$self->{during}' YAML file\n". + " '$self->{file}'\n". + "with '$self->{module}' some unknown error was encountered\n"; + } + } else { + return "Alert: While trying to '$self->{during}' YAML file\n". + " '$self->{file}'\n". + "some unknown error was encountered\n"; + } + } else { + return "Alert: While trying to '$self->{during}' some YAML file\n". + "some unknown error was encountered\n"; + } + } else { + return "Alert: unknown error encountered\n"; + } +} + +1; diff --git a/cpan/CPAN/lib/CPAN/FTP.pm b/cpan/CPAN/lib/CPAN/FTP.pm index 4f233814e5..997e141be5 100644 --- a/cpan/CPAN/lib/CPAN/FTP.pm +++ b/cpan/CPAN/lib/CPAN/FTP.pm @@ -21,6 +21,11 @@ $VERSION = "5.5005"; sub _ftp_statistics { my($self,$fh) = @_; 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 + # XXX read from the file using a different filehandle. + $locktype = LOCK_SH if $^O eq "MSWin32"; + $fh ||= FileHandle->new; my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml"); mkpath dirname $file; @@ -56,6 +61,7 @@ sub _ftp_statistics { $CPAN::Frontend->mydie($@); } } + CPAN::_flock($fh, LOCK_UN); return $stats->[0]; } @@ -567,7 +573,7 @@ sub hostdleasy { #called from hostdlxxx $ThesiteURL = $ro_url; return $l; } - # If request is for a compressed file and we can find the + # If request is for a compressed file and we can find the # uncompressed file also, return the path of the uncompressed file # otherwise, decompress it and return the resulting path if ($l =~ /(.+)\.gz$/) { @@ -975,7 +981,7 @@ ftp config variable with Trying with external ftp to get '$url' $netrc_explain - Going to send the dialog + Sending the dialog $dialog } ); @@ -1014,7 +1020,7 @@ $dialog $CPAN::Frontend->myprint(qq{ Trying with external ftp to get $url - Going to send the dialog + Sending the dialog $dialog } ); diff --git a/cpan/CPAN/lib/CPAN/FirstTime.pm b/cpan/CPAN/lib/CPAN/FirstTime.pm index 667bdca2f9..5030ef9b83 100644 --- a/cpan/CPAN/lib/CPAN/FirstTime.pm +++ b/cpan/CPAN/lib/CPAN/FirstTime.pm @@ -202,8 +202,8 @@ Preferred method for determining the current working directory? =item halt_on_failure Normally, CPAN.pm continues processing the full list of targets and -dependencies, even if one of them fails. However, you can specify -that CPAN should halt after the first failure. +dependencies, even if one of them fails. However, you can specify +that CPAN should halt after the first failure. Do you want to halt on failure (yes/no)? @@ -339,7 +339,7 @@ Your choice: Parameters for the './Build install' command? Typical frequently used setting: - --uninst 1 # uninstall conflicting files + --uninst 1 # uninstall conflicting files # (but do NOT use with local::lib or INSTALL_BASE) Your choice: @@ -781,8 +781,8 @@ sub init { if ( $args{autoconfig} ) { $auto_config = 1; } elsif ($matcher) { - $auto_config = 0; - } else { + $auto_config = 0; + } else { my $_conf = prompt($prompts{auto_config}, "yes"); $auto_config = ($_conf and $_conf =~ /^y/i) ? 1 : 0; } @@ -795,7 +795,7 @@ sub init { my $i_am_mad = 0; # silent prompting -- just quietly use default *_real_prompt = sub { return $_[1] }; - } + } # # bootstrap local::lib or sudo @@ -993,8 +993,8 @@ sub init { my_dflt_prompt(makepl_arg => "", $matcher); my_dflt_prompt(make_arg => "", $matcher); if ( $CPAN::Config->{makepl_arg} =~ /LIBS=|INC=/ ) { - $CPAN::Frontend->mywarn( - "Warning: Using LIBS or INC in makepl_arg will likely break distributions\n" . + $CPAN::Frontend->mywarn( + "Warning: Using LIBS or INC in makepl_arg will likely break distributions\n" . "that specify their own LIBS or INC options in Makefile.PL.\n" ); } @@ -1224,9 +1224,9 @@ sub init { ); } else { - $CPAN::Frontend->myprint( - "Autoconfigured everything but 'urllist'.\n" - ); + $CPAN::Frontend->myprint( + "Autoconfigured everything but 'urllist'.\n" + ); _do_pick_mirrors(); } } @@ -1247,8 +1247,8 @@ sub init { $CPAN::Frontend->myprint( "Skipping local::lib bootstrap because 'urllist' is not configured.\n" ); - } - else { + } + else { $CPAN::Frontend->myprint("\nAttempting to bootstrap local::lib...\n"); $CPAN::Frontend->myprint("\nWriting $configpm for bootstrap...\n"); delete $CPAN::Config->{install_help}; # temporary only @@ -1268,11 +1268,11 @@ sub init { $CPAN::Frontend->myprint("From the CPAN Shell, you might try 'look local::lib' and \n" . "run 'perl Makefile --bootstrap' and see if that is successful. Then\n" . "restart your CPAN client\n" - ); + ); } else { _local_lib_config(); - } + } } } @@ -1515,7 +1515,7 @@ ALERT: 'make' is an essential tool for building perl Modules. Please make sure you have 'make' (or some equivalent) working. HERE - if ($^O eq "MSWin32") { + if ($^O eq "MSWin32") { $CPAN::Frontend->mywarn(<<"HERE"); Windows users may want to follow this procedure when back in the CPAN shell: @@ -1528,7 +1528,7 @@ substitute. You can then revisit this dialog with o conf init make HERE - } + } } sub init_cpan_home { @@ -1657,7 +1657,7 @@ sub my_prompt_loop { # (2) We don't have a copy at all # (2a) If we are allowed to connect, we try to get a new copy. If it succeeds, # we use it, otherwise, we warn about failure -# (2b) If we aren't allowed to connect, +# (2b) If we aren't allowed to connect, sub conf_sites { my %args = @_; @@ -1732,7 +1732,7 @@ HERE } else { $CPAN::Frontend->mywarn(<<'HERE'); -You will need to provide CPAN mirror URLs yourself or set +You will need to provide CPAN mirror URLs yourself or set 'o conf connect_to_internet_ok 1' and try again. HERE } @@ -1851,7 +1851,9 @@ sub auto_mirrored_by { my $local = shift or return; local $|=1; $CPAN::Frontend->myprint("Looking for CPAN mirrors near you (please be patient)\n"); - my $mirrors = CPAN::Mirrors->new($local); + my $mirrors = CPAN::Mirrors->new; + $mirrors->parse_mirrored_by($local); + my $cnt = 0; my @best = $mirrors->best_mirrors( how_many => 3, @@ -1860,9 +1862,11 @@ sub auto_mirrored_by { if ($cnt++>60) { $cnt=0; $CPAN::Frontend->myprint("\n"); } }, ); + my $urllist = [ map { $_->http } @best ]; push @$urllist, grep { /^file:/ } @{$CPAN::Config->{urllist}}; $CPAN::Frontend->myprint(" done!\n\n"); + return $urllist } @@ -1998,8 +2002,8 @@ later if you\'re sure it\'s right.\n}, sub _print_urllist { my ($which) = @_; $CPAN::Frontend->myprint("$which urllist\n"); - for ( @{$CPAN::Config->{urllist} || []} ) { - $CPAN::Frontend->myprint(" $_\n") + for ( @{$CPAN::Config->{urllist} || []} ) { + $CPAN::Frontend->myprint(" $_\n") }; } diff --git a/cpan/CPAN/lib/CPAN/HTTP/Client.pm b/cpan/CPAN/lib/CPAN/HTTP/Client.pm index 52de7fe237..c5eb0f6a43 100644 --- a/cpan/CPAN/lib/CPAN/HTTP/Client.pm +++ b/cpan/CPAN/lib/CPAN/HTTP/Client.pm @@ -31,8 +31,8 @@ sub mirror { my($self, $uri, $path) = @_; my $want_proxy = $self->_want_proxy($uri); - my $http = HTTP::Tiny->new( - $want_proxy ? (proxy => $self->{proxy}) : () + my $http = HTTP::Tiny->new( + $want_proxy ? (proxy => $self->{proxy}) : () ); my ($response, %headers); @@ -112,7 +112,7 @@ sub _get_challenge { my $auth_list = $response->{headers}(lc $auth_header); return unless defined $auth_list; $auth_list = [$auth_list] unless ref $auth_list; - + for my $challenge (@$auth_list) { $challenge =~ tr/,/;/; # "," is used to separate auth-params!! ($challenge) = $self->split_header_words($challenge); diff --git a/cpan/CPAN/lib/CPAN/HandleConfig.pm b/cpan/CPAN/lib/CPAN/HandleConfig.pm index 58ccbe50e5..09c42efee0 100644 --- a/cpan/CPAN/lib/CPAN/HandleConfig.pm +++ b/cpan/CPAN/lib/CPAN/HandleConfig.pm @@ -265,11 +265,11 @@ sub commit { my($self,@args) = @_; CPAN->debug("args[@args]") if $CPAN::DEBUG; if ($CPAN::RUN_DEGRADED) { - $CPAN::Frontend->mydie( - "'o conf commit' disabled in ". - "degraded mode. Maybe try\n". - " !undef \$CPAN::RUN_DEGRADED\n" - ); + $CPAN::Frontend->mydie( + "'o conf commit' disabled in ". + "degraded mode. Maybe try\n". + " !undef \$CPAN::RUN_DEGRADED\n" + ); } my ($configpm, $must_reload); @@ -474,13 +474,13 @@ sub init { sub require_myconfig_or_config () { if ( $INC{"CPAN/MyConfig.pm"} || _try_loading("CPAN::MyConfig", cpan_home())) { return $INC{"CPAN/MyConfig.pm"}; - } + } elsif ( $INC{"CPAN/Config.pm"} || _try_loading("CPAN::Config") ) { return $INC{"CPAN/Config.pm"}; - } + } else { return q{}; - } + } } # Load a module, but ignore "can't locate..." errors @@ -495,8 +495,8 @@ sub _try_loading { if ( -f File::Spec->catfile($dir, $file) ) { unshift @INC, $dir; last; + } } - } eval { require $file }; my $err_myconfig = $@; @@ -515,7 +515,7 @@ sub cpan_home_dir_candidates { if ($^O ne 'darwin') { push @dirs, File::HomeDir->my_data; # my_data is ~/Library/Application Support on darwin, - # which causes issues in the toolchain. + # which causes issues in the toolchain. } push @dirs, File::HomeDir->my_home; } @@ -592,7 +592,7 @@ sub make_new_config { Old configuration file $configpm moved to $configpm_bak END - } + } } my $fh = FileHandle->new; if ($fh->open(">$configpm")) { diff --git a/cpan/CPAN/lib/CPAN/Index.pm b/cpan/CPAN/lib/CPAN/Index.pm index 4fcde8c390..af98d7bf15 100644 --- a/cpan/CPAN/lib/CPAN/Index.pm +++ b/cpan/CPAN/lib/CPAN/Index.pm @@ -132,7 +132,7 @@ sub reanimate_build_dir { return; } $CPAN::Frontend->myprint - (sprintf("Going to read %d yaml file%s from %s/\n", + (sprintf("Reading %d yaml file%s from %s/\n", scalar @candidates, @candidates==1 ? "" : "s", $CPAN::Config->{build_dir} @@ -231,7 +231,7 @@ sub rd_authindex { return unless defined $index_target; return if CPAN::_sqlite_running(); my @lines; - $CPAN::Frontend->myprint("Going to read '$index_target'\n"); + $CPAN::Frontend->myprint("Reading '$index_target'\n"); local(*FH); tie *FH, 'CPAN::Tarzip', $index_target; local($/) = "\n"; @@ -271,7 +271,7 @@ sub rd_modpacks { my($self, $index_target) = @_; return unless defined $index_target; return if CPAN::_sqlite_running(); - $CPAN::Frontend->myprint("Going to read '$index_target'\n"); + $CPAN::Frontend->myprint("Reading '$index_target'\n"); my $fh = CPAN::Tarzip->TIEHANDLE($index_target); local $_; CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG; @@ -494,7 +494,7 @@ sub rd_modlist { my($cl,$index_target) = @_; return unless defined $index_target; return if CPAN::_sqlite_running(); - $CPAN::Frontend->myprint("Going to read '$index_target'\n"); + $CPAN::Frontend->myprint("Reading '$index_target'\n"); my $fh = CPAN::Tarzip->TIEHANDLE($index_target); local $_; my $slurp = ""; @@ -556,7 +556,7 @@ sub write_metadata_cache { $cache->{last_time} = $LAST_TIME; $cache->{DATE_OF_02} = $DATE_OF_02; $cache->{PROTOCOL} = PROTOCOL; - $CPAN::Frontend->myprint("Going to write $metadata_file\n"); + $CPAN::Frontend->myprint("Writing $metadata_file\n"); eval { Storable::nstore($cache, $metadata_file) }; $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ?? } @@ -569,7 +569,7 @@ sub read_metadata_cache { return unless $CPAN::META->has_usable("Storable"); my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata"); return unless -r $metadata_file and -f $metadata_file; - $CPAN::Frontend->myprint("Going to read '$metadata_file'\n"); + $CPAN::Frontend->myprint("Reading '$metadata_file'\n"); my $cache; eval { $cache = Storable::retrieve($metadata_file) }; $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ?? diff --git a/cpan/CPAN/lib/CPAN/Mirrors.pm b/cpan/CPAN/lib/CPAN/Mirrors.pm index 3582b0acb4..daafc1dbaf 100644 --- a/cpan/CPAN/lib/CPAN/Mirrors.pm +++ b/cpan/CPAN/lib/CPAN/Mirrors.pm @@ -1,5 +1,37 @@ # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- # vim: ts=4 sts=4 sw=4: +=head1 NAME + +CPAN::Mirrors - Get CPAN miror information and select a fast one + +=head1 SYNOPSIS + + use CPAN::Mirrors; + + my $mirrors = CPAN::Mirrors->new; + $mirrors->parse_from_file( $mirrored_by_file ); + + my $seen = {}; + + my $best_continent = $mirrors->find_best_continents( { seen => $seen } ); + my @mirrors = $mirrors->get_mirrors_by_continents( $best_continent ); + + my $callback = sub { + my( $m ) = @_; + printf "%s = %s\n", $m->hostname, $m->rtt + }; + $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback ); + + @mirrors = sort { $a->rtt <=> $b->rtt } @mirrors; + + print "Best mirrors are ", map( { $_->rtt } @mirrors[0..3] ), "\n"; + +=head1 DESCRIPTION + +=over + +=cut + package CPAN::Mirrors; use strict; use vars qw($VERSION $urllist $silent); @@ -10,31 +42,55 @@ use FileHandle; use Fcntl ":flock"; use Net::Ping (); +=item new( LOCAL_FILE_NAME ) + +=cut + sub new { my ($class, $file) = @_; - my $self = bless { - mirrors => [], - geography => {}, + my $self = bless { + mirrors => [], + geography => {}, }, $class; + if( defined $file ) { + $self->parse_mirrored_by( $file ); + } + + return $self +} + +sub parse_mirrored_by { + my ($self, $file) = @_; my $handle = FileHandle->new; - $handle->open($file) + $handle->open($file) or croak "Couldn't open $file: $!"; flock $handle, LOCK_SH; $self->_parse($file,$handle); flock $handle, LOCK_UN; $handle->close; +} - # populate continents & countries +=item continents() - return $self -} +Return a list of continents based on those defined in F<MIRRORED.BY>. + +=cut sub continents { my ($self) = @_; return keys %{$self->{geography}}; } +=item countries( [CONTINENTS] ) + +Return a list of countries based on those defined in F<MIRRORED.BY>. +It only returns countries for the continents you specify (as defined +in C<continents>). If you don't specify any continents, it returns all +of the countries listed in F<MIRRORED.BY>. + +=cut + sub countries { my ($self, @continents) = @_; @continents = $self->continents unless @continents; @@ -45,6 +101,15 @@ sub countries { return @countries; } +=item mirrors( [COUNTRIES] ) + +Return a list of mirrors based on those defined in F<MIRRORED.BY>. +It only returns mirrors for the countries you specify (as defined +in C<countries>). If you don't specify any countries, it returns all +of the mirrors listed in F<MIRRORED.BY>. + +=cut + sub mirrors { my ($self, @countries) = @_; return @{$self->{mirrors}} unless @countries; @@ -56,118 +121,300 @@ sub mirrors { return @found; } +=item get_mirrors_by_countries( [COUNTRIES] ) + +A more sensible synonym for mirrors. + +=cut + +sub get_mirrors_by_countries { &mirrors } + +=item get_mirrors_by_continents( [CONTINENTS] ) + +Return a list of mirrors for all of continents you specify. If you don't +specify any continents, it returns all of the mirrors. + +=cut + +sub get_mirrors_by_continents { + my ($self, $continents ) = @_; + + $self->mirrors( $self->get_countries_by_continents( @$continents ) ); + } + +=item get_countries_by_continents( [CONTINENTS] ) + +A more sensible synonym for countries. + +=cut +sub get_countries_by_continents { &countries } + +=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. +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 + +If you don't specify the continents, C<best_mirrors> calls +C<find_best_continents> to get the list of continents to check. + +=cut + sub best_mirrors { my ($self, %args) = @_; - my $how_many = $args{how_many} || 1; - my $callback = $args{callback}; - my $verbose = $args{verbose}; - my $conts = $args{continents} || []; - $conts = [$conts] unless ref $conts; + my $how_many = $args{how_many} || 1; + my $callback = $args{callback}; + my $verbose = defined $args{verbose} ? $args{verbose} : 0; + my $continents = $args{continents} || []; + $continents = [$continents] unless ref $continents; # Old Net::Ping did not do timings at all return "http://www.cpan.org/" unless Net::Ping->VERSION gt '2.13'; my $seen = {}; - if ( ! @$conts ) { + if ( ! @$continents ) { print "Searching for the best continent ...\n" if $verbose; - my @best = $self->_find_best_continent($seen, $verbose, $callback); + my @best_continents = $self->find_best_continents( + seen => $seen, + verbose => $verbose, + callback => $callback, + ); # Only add enough continents to find enough mirrors my $count = 0; - for my $c ( @best ) { - push @$conts, $c; - $count += $self->mirrors( $self->countries($c) ); + for my $continent ( @best_continents ) { + push @$continents, $continent; + $count += $self->mirrors( $self->countries($continent) ); last if $count >= $how_many; } } - print "Scanning " . join(", ", @$conts) . " ...\n" if $verbose; + 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; + + $how_many = @$timings if $how_many > @$timings; + + return wantarray ? @{$timings}[0 .. $how_many-1] : $timings->[0]; +} + +=item get_n_random_mirrors_by_continents( N, [CONTINENTS] + +Returns up to N random mirrors for the specified continents. Specify the +continents as an array reference. + +=cut + +sub get_n_random_mirrors_by_continents { + my( $self, $n, $continents ) = @_; + $n ||= 3; + $continents = [ $continents ] unless ref $continents; - my @timings; - my @long_list = $self->mirrors($self->countries(@$conts)); - my $long_list_size = ( $how_many > 10 ? $how_many : 10 ); - if ( @long_list > $long_list_size ) { - @long_list = map {$_->[0]} - sort {$a->[1] <=> $b->[1]} - map {[$_, rand]} @long_list; - splice @long_list, $long_list_size; # truncate + if ( $n <= 0 ) { + return wantarray ? () : []; } - for my $m ( @long_list ) { - next unless $m->http; - my $hostname = $m->hostname; - if ( $seen->{$hostname} ) { - push @timings, $seen->{$hostname} - if defined $seen->{$hostname}[1]; + my @long_list = $self->get_mirrors_by_continents( $continents ); + + if ( $n eq '*' or $n > @long_list ) { + return wantarray ? @long_list : \@long_list; + } + + @long_list = map {$_->[0]} + sort {$a->[1] <=> $b->[1]} + map {[$_, rand]} @long_list; + + splice @long_list, $n; # truncate + + \@long_list; +} + +=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK ); + +Pings the listed mirrors and returns a list of mirrors sorted +in ascending ping times. + +=cut + +sub get_mirrors_timings { + my( $self, $mirror_list, $seen, $callback ) = @_; + + $seen = {} unless defined $seen; + croak "The mirror list argument must be an array reference" + unless ref $mirror_list eq ref []; + croak "The seen argument must be a hash reference" + unless ref $seen eq ref {}; + croak "callback must be a subroutine" + if( defined $callback and ref $callback ne ref sub {} ); + + my $timings = []; + for my $m ( @$mirror_list ) { + $seen->{$m->hostname} = $m; + next unless eval{ $m->http }; + + if( $self->_try_a_ping( $seen, $m, ) ) { + my $ping = $m->ping; + next unless defined $ping; + push @$timings, $m; + $callback->( $m ) if $callback; } else { - my $ping = $m->ping; - next unless defined $ping; - push @timings, [$m, $ping]; - $callback->($m,$ping) if $callback; + push @$timings, $seen->{$m->hostname} + if defined $seen->{$m->hostname}->rtt; } } - return unless @timings; - - $how_many = @timings if $how_many > @timings; - my @best = - map { $_->[0] } - sort { $a->[1] <=> $b->[1] } @timings; - return wantarray ? @best[0 .. $how_many-1] : $best[0]; + my @best = sort { + if( defined $a->rtt and defined $b->rtt ) { + $a->rtt <=> $b->rtt + } + elsif( defined $a->rtt and ! defined $b->rtt ) { + return -1; + } + elsif( ! defined $a->rtt and defined $b->rtt ) { + return 1; + } + elsif( ! defined $a->rtt and ! defined $b->rtt ) { + return 0; + } + + } @$timings; + + return wantarray ? @best : \@best; } -sub _find_best_continent { - my ($self, $seen, $verbose, $callback) = @_; +=item find_best_continents( HASH_REF ); + +C<find_best_continents> goes through each continent and pings C<N> random +mirrors on that continent. It then orders the continents by ascending +median ping time. In list context, it returns the ordered list of +continent. In scalar context, it returns the same list as an anonymous +array. + +Arguments: + + n - the number of hosts to ping for each continent. Default: 3 + seen - a hashref of cached hostname ping times + verbose - true or false for noisy or quiet. Default: false + callback - a subroutine to run after each ping. + ping_cache_limit - how long, in seconds, to reuse previous ping times. + Default: 1 day + +The C<seen> hash has hostnames as keys and anonymous arrays as values. The +anonymous array is a triplet of a C<CPAN::Mirrored::By> object, a ping +time, and the epoch time for the measurement. + +The callback subroutine gets the C<CPAN::Mirrored::By> object, the ping +time, and measurement time (the same things in the C<seen> hashref) as arguments. +C<find_best_continents> doesn't care what the callback does and ignores the return +value. - my %median; +=cut + +sub find_best_continents { + my ($self, %args) = @_; + + $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}; + 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) ); + next CONT unless @mirrors; - my $sample = 3; - my $n = (@mirrors < $sample) ? @mirrors : $sample; + my $n = (@mirrors < $args{n}) ? @mirrors : $args{n}; + my @tests; - RANDOM: while ( @mirrors && @tests < $n ) { + my $tries = 0; + RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) { my $m = splice( @mirrors, int(rand(@mirrors)), 1 ); - my $ping = $m->ping; - $callback->($m,$ping) if $callback; - # record undef so we don't try again - $seen->{$m->hostname} = [$m, $ping]; - next RANDOM unless defined $ping; - push @tests, $ping; - } - next CONT unless @tests; - @tests = sort { $a <=> $b } @tests; - if ( @tests == 1 ) { - $median{$c} = $tests[0]; - } - elsif ( @tests % 2 ) { - $median{$c} = $tests[ int(@tests / 2) ]; - } - else { - my $mid_high = int(@tests/2); - $median{$c} = ($tests[$mid_high-1] + $tests[$mid_high])/2; + if( $self->_try_a_ping( $args{seen}, $m, $args{ping_cache_limit} ) ) { + $self->get_mirrors_timings( [ $m ], @args{qw(seen callback)} ); + next RANDOM unless defined $args{seen}{$m->hostname}->rtt; + } + printf "\t%s -> %0.2f ms\n", + $m->hostname, + join ' ', 1000 * $args{seen}{$m->hostname}->rtt + if $args{verbose}; + + push @tests, $args{seen}{$m->hostname}->rtt; } + + my $median = $self->_get_median_ping_time( \@tests, $args{verbose} ); + $medians{$c} = $median if defined $median; } - my @best_cont = sort { $median{$a} <=> $median{$b} } keys %median ; + my @best_cont = sort { $medians{$a} <=> $medians{$b} } keys %medians; - if ( $verbose ) { + if ( $args{verbose} ) { print "Median result by continent:\n"; for my $c ( @best_cont ) { - printf( " %d ms %s\n", int($median{$c}*1000+.5), $c ); + printf( " %4d ms %s\n", int($medians{$c}*1000+.5), $c ); } } return wantarray ? @best_cont : $best_cont[0]; } +# retry if +sub _try_a_ping { + my ($self, $seen, $mirror, $ping_cache_limit ) = @_; + + ( ! exists $seen->{$mirror->hostname} ) + or + ( + ! defined $seen->{$mirror->hostname}->rtt + or + time - $seen->{$mirror->hostname}->rtt > $ping_cache_limit + ) +} + +sub _get_median_ping_time { + my ($self, $tests, $verbose ) = @_; + + my @sorted = sort { $a <=> $b } @$tests; + + my $median = do { + if ( @sorted == 0 ) { undef } + elsif ( @sorted == 1 ) { $sorted[0] } + elsif ( @sorted % 2 ) { $sorted[ int(@sorted / 2) ] } + else { + my $mid_high = int(@sorted/2); + ($sorted[$mid_high-1] + $sorted[$mid_high])/2; + } + }; + + printf "\t-->median time: %0.2f ms\n", $median * 1000 if $verbose; + + return $median; +} + # Adapted from Parse::CPAN::MirroredBy by Adam Kennedy sub _parse { my ($self, $file, $handle) = @_; my $output = $self->{mirrors}; - my $geo = $self->{geography}; + my $geo = $self->{geography}; local $/ = "\012"; my $line = 0; @@ -193,7 +440,7 @@ sub _parse { $mirror ||= {}; if ( $prop eq 'dst_location' ) { my (@location,$continent,$country); - @location = (split /\s*,\s*/, $value) + @location = (split /\s*,\s*/, $value) and ($continent, $country) = @location[-1,-2]; $continent =~ s/\s\(.*//; $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude @@ -244,35 +491,61 @@ sub new { $arg ||= {}; bless $arg, $self; } -sub hostname { shift->{hostname} } -sub continent { shift->{continent} } -sub country { shift->{country} } -sub http { shift->{http} || '' } -sub ftp { shift->{ftp} || '' } -sub rsync { shift->{rsync} || '' } - -sub url { +sub hostname { shift->{hostname} } +sub continent { shift->{continent} } +sub country { shift->{country} } +sub http { shift->{http} || '' } +sub ftp { shift->{ftp} || '' } +sub rsync { shift->{rsync} || '' } +sub rtt { shift->{rtt} } +sub ping_time { shift->{ping_time} } + +sub url { my $self = shift; return $self->{http} || $self->{ftp}; } sub ping { my $self = shift; + my $ping = Net::Ping->new("tcp",1); my ($proto) = $self->url =~ m{^([^:]+)}; my $port = $proto eq 'http' ? 80 : 21; return unless $port; - if ( $ping->can('port_number') ) { - $ping->port_number($port); + + if ( $ping->can('port_number') ) { + $ping->port_number($port); } else { $ping->{'port_num'} = $port; } + $ping->hires(1) if $ping->can('hires'); my ($alive,$rtt) = $ping->ping($self->hostname); - return $alive ? $rtt : undef; + + $self->{rtt} = $alive ? $rtt : undef; + $self->{ping_time} = time; + + $self->rtt; } 1; +=back + +=head1 AUTHOR + +Andreas Koenig C<< <andk@cpan.org> >>, David Golden C<< <dagolden@cpan.org> >>, +brian d foy C<< <bdfoy@cpan.org> >> + +=head1 LICENSE + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See L<http://www.perl.com/perl/misc/Artistic.html> + + + +=cut diff --git a/cpan/CPAN/lib/CPAN/Shell.pm b/cpan/CPAN/lib/CPAN/Shell.pm index 9effb0d2e7..21441df653 100644 --- a/cpan/CPAN/lib/CPAN/Shell.pm +++ b/cpan/CPAN/lib/CPAN/Shell.pm @@ -653,7 +653,7 @@ sub mkmyconfig { "CPAN::MyConfig already exists as $configpm.\n" . "Running configuration again...\n" ); - require CPAN::FirstTime; + require CPAN::FirstTime; CPAN::FirstTime::init($configpm); } else { @@ -1221,6 +1221,7 @@ sub autobundle { $fh->close; $CPAN::Frontend->myprint("\nWrote bundle file $to\n\n"); + return $to; } #-> sub CPAN::Shell::expandany ; @@ -1684,7 +1685,7 @@ sub rematein { if ($meth =~ /^($needs_recursion_protection)$/) { # it would be silly to check for recursion for look or dump # (we are in CPAN::Shell::rematein) - CPAN->debug("Going to test against recursion") if $CPAN::DEBUG; + CPAN->debug("Testing against recursion") if $CPAN::DEBUG; eval { $obj->color_cmd_tmps(0,1); }; if ($@) { if (ref $@ @@ -1847,7 +1848,7 @@ sub recent { my($self) = @_; if ($CPAN::META->has_inst("XML::LibXML")) { my $url = $CPAN::Defaultrecent; - $CPAN::Frontend->myprint("Going to fetch '$url'\n"); + $CPAN::Frontend->myprint("Fetching '$url'\n"); unless ($CPAN::META->has_usable("LWP")) { $CPAN::Frontend->mydie("LWP not installed; cannot continue"); } @@ -1935,7 +1936,7 @@ sub smoke { my $distros = $self->recent; DISTRO: for my $distro (@$distros) { next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles - $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n"); + $CPAN::Frontend->myprint(sprintf "Downloading and testing '$distro'\n"); { my $skip = 0; local $SIG{INT} = sub { $skip = 1 }; |