diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm | 119 |
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; |