diff options
Diffstat (limited to 'cpan/CPAN/lib/CPAN/Mirrors.pm')
| -rw-r--r-- | cpan/CPAN/lib/CPAN/Mirrors.pm | 439 |
1 files changed, 356 insertions, 83 deletions
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 |