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.pm296
1 files changed, 167 insertions, 129 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
index 38e0043d7a4..37e7ce0ef9f 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
@@ -2,29 +2,28 @@
# vim: ts=4 sts=4 sw=4:
=head1 NAME
-CPAN::Mirrors - Get CPAN miror information and select a fast one
+CPAN::Mirrors - Get CPAN mirror information and select a fast one
=head1 SYNOPSIS
- use CPAN::Mirrors;
+ use CPAN::Mirrors;
- my $mirrors = CPAN::Mirrors->new;
- $mirrors->parse_from_file( $mirrored_by_file );
+ my $mirrors = CPAN::Mirrors->new( $mirrored_by_file );
- my $seen = {};
+ my $seen = {};
- my $best_continent = $mirrors->find_best_continents( { seen => $seen } );
- my @mirrors = $mirrors->get_mirrors_by_continents( $best_continent );
+ 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 );
+ 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;
+ @mirrors = sort { $a->rtt <=> $b->rtt } @mirrors;
- print "Best mirrors are ", map( { $_->rtt } @mirrors[0..3] ), "\n";
+ print "Best mirrors are ", map( { $_->rtt } @mirrors[0..3] ), "\n";
=head1 DESCRIPTION
@@ -35,7 +34,7 @@ CPAN::Mirrors - Get CPAN miror information and select a fast one
package CPAN::Mirrors;
use strict;
use vars qw($VERSION $urllist $silent);
-$VERSION = "1.9600";
+$VERSION = "1.9601";
use Carp;
use FileHandle;
@@ -44,24 +43,28 @@ use Net::Ping ();
=item new( LOCAL_FILE_NAME )
+Create a new CPAN::Mirrors object from LOCAL_FILE_NAME. This file
+should look like that in http://www.cpan.org/MIRRORED.BY .
+
=cut
sub new {
my ($class, $file) = @_;
+ croak "CPAN::Mirrors->new requires a filename" unless defined $file;
+ croak "The file [$file] was not found" unless -e $file;
+
my $self = bless {
mirrors => [],
geography => {},
}, $class;
- if( defined $file ) {
- $self->parse_mirrored_by( $file );
- }
+ $self->parse_mirrored_by( $file );
- return $self
+ return $self;
}
sub parse_mirrored_by {
- my ($self, $file) = @_;
+ my ($self, $file) = @_;
my $handle = FileHandle->new;
$handle->open($file)
or croak "Couldn't open $file: $!";
@@ -134,21 +137,36 @@ sub get_mirrors_by_countries { &mirrors }
Return a list of mirrors for all of continents you specify. If you don't
specify any continents, it returns all of the mirrors.
+You can specify a single continent or an array reference of continents.
+
=cut
sub get_mirrors_by_continents {
- my ($self, $continents ) = @_;
+ my ($self, $continents ) = @_;
+ $continents = [ $continents ] unless ref $continents;
- $self->mirrors( $self->get_countries_by_continents( @$continents ) );
- }
+ eval {
+ $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 default_mirror
+
+Returns the default mirror, http://www.cpan.org/ . This mirror uses
+dynamic DNS to give a close mirror.
+
+=cut
+
+sub default_mirror { 'http://www.cpan.org/' }
+
=item best_mirrors
C<best_mirrors> checks for the best mirrors based on the list of
@@ -159,14 +177,17 @@ 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
If you don't specify the continents, C<best_mirrors> calls
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.
+
=cut
sub best_mirrors {
@@ -178,17 +199,22 @@ sub best_mirrors {
$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 $min_version = '2.13';
+ unless( Net::Ping->VERSION gt $min_version ) {
+ carp sprintf "Net::Ping version is %s (< %s). Returning %s",
+ Net::Ping->VERSION, $min_version, $self->default_mirror;
+ return $self->default_mirror;
+ }
my $seen = {};
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,
+ );
# Only add enough continents to find enough mirrors
my $count = 0;
@@ -201,7 +227,7 @@ sub best_mirrors {
print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose;
- my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] );
+ 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;
@@ -211,7 +237,7 @@ sub best_mirrors {
return wantarray ? @{$timings}[0 .. $how_many-1] : $timings->[0];
}
-=item get_n_random_mirrors_by_continents( N, [CONTINENTS]
+=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.
@@ -219,55 +245,65 @@ 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( $self, $n, $continents ) = @_;
+ $n ||= 3;
+ $continents = [ $continents ] unless ref $continents;
if ( $n <= 0 ) {
- return wantarray ? () : [];
+ return wantarray ? () : [];
}
my @long_list = $self->get_mirrors_by_continents( $continents );
if ( $n eq '*' or $n > @long_list ) {
- return wantarray ? @long_list : \@long_list;
+ return wantarray ? @long_list : \@long_list;
}
- @long_list = map {$_->[0]}
- sort {$a->[1] <=> $b->[1]}
+ @long_list = map {$_->[0]}
+ sort {$a->[1] <=> $b->[1]}
map {[$_, rand]} @long_list;
- splice @long_list, $n; # truncate
+ splice @long_list, $n; # truncate
- \@long_list;
+ \@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.
+Pings the listed mirrors and returns a list of mirrors sorted in
+ascending ping times.
+
+C<MIRROR_LIST> is an anonymous array of C<CPAN::Mirrored::By> objects to
+ping.
+
+The optional argument C<SEEN> is a hash reference used to track the
+mirrors you've already pinged.
+
+The optional argument C<CALLBACK> is a subroutine reference to call
+after each ping. It gets the C<CPAN::Mirrored::By> object after each
+ping.
=cut
sub get_mirrors_timings {
- my( $self, $mirror_list, $seen, $callback ) = @_;
+ 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 {} );
+ $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 = [];
+ my $timings = [];
for my $m ( @$mirror_list ) {
- $seen->{$m->hostname} = $m;
- next unless eval{ $m->http };
+ $seen->{$m->hostname} = $m;
+ next unless eval{ $m->http };
if( $self->_try_a_ping( $seen, $m, ) ) {
my $ping = $m->ping;
- next unless defined $ping;
+ next unless defined $ping;
push @$timings, $m;
$callback->( $m ) if $callback;
}
@@ -278,48 +314,52 @@ sub get_mirrors_timings {
}
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;
+ 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;
}
=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.
+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
+ 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 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
+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.
+
+With a low value for C<N>, a single mirror might skew the results enough
+to choose a worse continent. If you have that problem, try a larger
value.
=cut
@@ -327,19 +367,19 @@ value.
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 {} );
+ $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};
+ print "Testing $c\n" if $args{verbose};
my @mirrors = $self->mirrors( $self->countries($c) );
next CONT unless @mirrors;
@@ -350,19 +390,19 @@ sub find_best_continents {
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{qw(seen callback)} );
- next RANDOM unless defined $args{seen}{$m->hostname}->rtt;
+ $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};
+ $m->hostname,
+ join ' ', 1000 * $args{seen}{$m->hostname}->rtt
+ if $args{verbose};
- push @tests, $args{seen}{$m->hostname}->rtt;
+ push @tests, $args{seen}{$m->hostname}->rtt;
}
- my $median = $self->_get_median_ping_time( \@tests, $args{verbose} );
- $medians{$c} = $median if defined $median;
+ my $median = $self->_get_median_ping_time( \@tests, $args{verbose} );
+ $medians{$c} = $median if defined $median;
}
my @best_cont = sort { $medians{$a} <=> $medians{$b} } keys %medians;
@@ -379,33 +419,33 @@ sub find_best_continents {
# 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
- )
+ 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 ($self, $tests, $verbose ) = @_;
- my @sorted = sort { $a <=> $b } @$tests;
+ 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;
- }
- };
+ 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;
+ printf "\t-->median time: %0.2f ms\n", $median * 1000 if $verbose;
return $median;
}
@@ -513,7 +553,7 @@ sub ping {
my $port = $proto eq 'http' ? 80 : 21;
return unless $port;
- if ( $ping->can('port_number') ) {
+ if ( $ping->can('port_number') ) {
$ping->port_number($port);
}
else {
@@ -546,6 +586,4 @@ modify it under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
-
-
=cut