summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm119
1 files changed, 84 insertions, 35 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
index 29bb7216ffc..721ead2a85d 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
@@ -19,7 +19,7 @@ CPAN::Mirrors - Get CPAN mirror information and select a fast one
my( $m ) = @_;
printf "%s = %s\n", $m->hostname, $m->rtt
};
- $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback );
+ $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback, %args );
@mirrors = sort { $a->rtt <=> $b->rtt } @mirrors;
@@ -34,12 +34,13 @@ CPAN::Mirrors - Get CPAN mirror information and select a fast one
package CPAN::Mirrors;
use strict;
use vars qw($VERSION $urllist $silent);
-$VERSION = "2.21";
+$VERSION = "2.27";
use Carp;
use FileHandle;
use Fcntl ":flock";
use Net::Ping ();
+use CPAN::Version;
=item new( LOCAL_FILE_NAME )
@@ -82,7 +83,7 @@ Return a list of continents based on those defined in F<MIRRORED.BY>.
sub continents {
my ($self) = @_;
- return sort keys %{$self->{geography}};
+ return sort keys %{$self->{geography} || {}};
}
=item countries( [CONTINENTS] )
@@ -99,7 +100,7 @@ sub countries {
@continents = $self->continents unless @continents;
my @countries;
for my $c (@continents) {
- push @countries, sort keys %{ $self->{geography}{$c} };
+ push @countries, sort keys %{ $self->{geography}{$c} || {} };
}
return @countries;
}
@@ -165,22 +166,25 @@ dynamic DNS to give a close mirror.
=cut
-sub default_mirror { 'http://www.cpan.org/' }
+sub default_mirror {
+ CPAN::Mirrored::By->new({ http => 'http://www.cpan.org/'});
+}
=item best_mirrors
C<best_mirrors> checks for the best mirrors based on the list of
continents you pass, or, without that, all continents, as defined
by C<CPAN::Mirrored::By>. It pings each mirror, up to the value of
-C<how_many>. In list context, it returns up to C<how_many> mirror.
+C<how_many>. In list context, it returns up to C<how_many> mirrors.
In scalar context, it returns the single best mirror.
Arguments
- how_many - the number of mirrors to return. Default: 1
- callback - a callback for find_best_continents
- verbose - true or false on all the whining and moaning. Default: false
- continents - an array ref of the continents to check
+ how_many - the number of mirrors to return. Default: 1
+ callback - a callback for find_best_continents
+ verbose - true or false on all the whining and moaning. Default: false
+ continents - an array ref of the continents to check
+ external_ping - if true, use external ping via Net::Ping::External. Default: false
If you don't specify the continents, C<best_mirrors> calls
C<find_best_continents> to get the list of continents to check.
@@ -188,6 +192,9 @@ C<find_best_continents> to get the list of continents to check.
If you don't have L<Net::Ping> v2.13 or later, needed for timings,
this returns the default mirror.
+C<external_ping> should be set and then C<Net::Ping::External> needs
+to be installed, if the local network has a transparent proxy.
+
=cut
sub best_mirrors {
@@ -197,10 +204,12 @@ sub best_mirrors {
my $verbose = defined $args{verbose} ? $args{verbose} : 0;
my $continents = $args{continents} || [];
$continents = [$continents] unless ref $continents;
+ $args{external_ping} = 0 unless defined $args{external_ping};
+ my $external_ping = $args{external_ping};
# Old Net::Ping did not do timings at all
my $min_version = '2.13';
- unless( Net::Ping->VERSION gt $min_version ) {
+ unless( CPAN::Version->vgt(Net::Ping->VERSION, $min_version) ) {
carp sprintf "Net::Ping version is %s (< %s). Returning %s",
Net::Ping->VERSION, $min_version, $self->default_mirror;
return $self->default_mirror;
@@ -211,9 +220,10 @@ sub best_mirrors {
if ( ! @$continents ) {
print "Searching for the best continent ...\n" if $verbose;
my @best_continents = $self->find_best_continents(
- seen => $seen,
- verbose => $verbose,
- callback => $callback,
+ seen => $seen,
+ verbose => $verbose,
+ callback => $callback,
+ external_ping => $external_ping,
);
# Only add enough continents to find enough mirrors
@@ -225,12 +235,18 @@ sub best_mirrors {
}
}
+ return $self->default_mirror unless @$continents;
print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose;
my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] );
- my $timings = $self->get_mirrors_timings( $trial_mirrors, $seen, $callback );
- return [] unless @$timings;
+ my $timings = $self->get_mirrors_timings(
+ $trial_mirrors,
+ $seen,
+ $callback,
+ %args,
+ );
+ return $self->default_mirror unless @$timings;
$how_many = @$timings if $how_many > @$timings;
@@ -268,7 +284,7 @@ sub get_n_random_mirrors_by_continents {
\@long_list;
}
-=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK );
+=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK, %ARGS );
Pings the listed mirrors and returns a list of mirrors sorted in
ascending ping times.
@@ -286,7 +302,7 @@ ping.
=cut
sub get_mirrors_timings {
- my( $self, $mirror_list, $seen, $callback ) = @_;
+ my( $self, $mirror_list, $seen, $callback, %args ) = @_;
$seen = {} unless defined $seen;
croak "The mirror list argument must be an array reference"
@@ -302,8 +318,9 @@ sub get_mirrors_timings {
next unless eval{ $m->http };
if( $self->_try_a_ping( $seen, $m, ) ) {
- my $ping = $m->ping;
+ my $ping = $m->ping(%args);
next unless defined $ping;
+ # printf "m %s ping %s\n", $m, $ping;
push @$timings, $m;
$callback->( $m ) if $callback;
}
@@ -367,20 +384,21 @@ value.
sub find_best_continents {
my ($self, %args) = @_;
- $args{n} ||= 3;
+ $args{n} ||= 3;
$args{verbose} = 0 unless defined $args{verbose};
$args{seen} = {} unless defined $args{seen};
croak "The seen argument must be a hash reference"
unless ref $args{seen} eq ref {};
$args{ping_cache_limit} = 24 * 60 * 60
- unless defined $args{ping_cache_time};
+ unless defined $args{ping_cache_limit};
croak "callback must be a subroutine"
if( defined $args{callback} and ref $args{callback} ne ref sub {} );
my %medians;
CONT: for my $c ( $self->continents ) {
- print "Testing $c\n" if $args{verbose};
my @mirrors = $self->mirrors( $self->countries($c) );
+ printf "Testing %s (%d mirrors)\n", $c, scalar @mirrors
+ if $args{verbose};
next CONT unless @mirrors;
my $n = (@mirrors < $args{n}) ? @mirrors : $args{n};
@@ -389,11 +407,18 @@ sub find_best_continents {
my $tries = 0;
RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) {
my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
- if( $self->_try_a_ping( $args{seen}, $m, $args{ping_cache_limit} ) ) {
- $self->get_mirrors_timings( [ $m ], $args{seen}, $args{callback} );
+ if( $self->_try_a_ping(
+ $args{seen}, $m, $args{ping_cache_limit}
+ )) {
+ $self->get_mirrors_timings(
+ [ $m ],
+ $args{seen},
+ $args{callback},
+ %args,
+ );
next RANDOM unless defined $args{seen}{$m->hostname}->rtt;
}
- printf "\t%s -> %0.2f ms\n",
+ printf "(%s -> %0.2f ms)",
$m->hostname,
join ' ', 1000 * $args{seen}{$m->hostname}->rtt
if $args{verbose};
@@ -409,8 +434,12 @@ sub find_best_continents {
if ( $args{verbose} ) {
print "Median result by continent:\n";
- for my $c ( @best_cont ) {
- printf( " %4d ms %s\n", int($medians{$c}*1000+.5), $c );
+ if ( @best_cont ) {
+ for my $c ( @best_cont ) {
+ printf( " %7.2f ms %s\n", $medians{$c}*1000, $c );
+ }
+ } else {
+ print " **** No results found ****\n"
}
}
@@ -421,12 +450,14 @@ sub find_best_continents {
sub _try_a_ping {
my ($self, $seen, $mirror, $ping_cache_limit ) = @_;
- ( ! exists $seen->{$mirror->hostname} )
+ ( ! exists $seen->{$mirror->hostname}
or
- (
! defined $seen->{$mirror->hostname}->rtt
- or
- time - $seen->{$mirror->hostname}->rtt > $ping_cache_limit
+ or
+ ! defined $ping_cache_limit
+ or
+ time - $seen->{$mirror->hostname}->ping_time
+ > $ping_cache_limit
)
}
@@ -445,7 +476,13 @@ sub _get_median_ping_time {
}
};
- printf "\t-->median time: %0.2f ms\n", $median * 1000 if $verbose;
+ if ($verbose){
+ if ($median) {
+ printf " => median time: %.2f ms\n", $median * 1000
+ } else {
+ printf " => **** no median time ****\n";
+ }
+ }
return $median;
}
@@ -546,9 +583,17 @@ sub url {
}
sub ping {
- my $self = shift;
+ my($self, %args) = @_;
- my $ping = Net::Ping->new($^O eq 'VMS' ? 'icmp' : 'tcp', 1);
+ my $external_ping = $args{external_ping};
+ if ($external_ping) {
+ eval { require Net::Ping::External }
+ or die "Net::Ping::External required to use external ping command";
+ }
+ my $ping = Net::Ping->new(
+ $external_ping ? 'external' : $^O eq 'VMS' ? 'icmp' : 'tcp',
+ 1
+ );
my ($proto) = $self->url =~ m{^([^:]+)};
my $port = $proto eq 'http' ? 80 : 21;
return unless $port;
@@ -561,7 +606,11 @@ sub ping {
}
$ping->hires(1) if $ping->can('hires');
- my ($alive,$rtt) = $ping->ping($self->hostname);
+ my ($alive,$rtt) = eval { $ping->ping($self->hostname); };
+ my $verbose = $args{verbose};
+ if ($verbose && !$alive) {
+ printf "(host %s not alive)", $self->hostname;
+ }
$self->{rtt} = $alive ? $rtt : undef;
$self->{ping_time} = time;