File Coverage

blib/lib/CPAN/Mirrors.pm
Criterion Covered Total %
statement 34 257 13.2
branch 0 176 0.0
condition 2 55 3.6
subroutine 13 38 34.2
pod 12 13 92.3
total 61 539 11.3


line stmt bran cond sub pod time code
1             # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2             # vim: ts=4 sts=4 sw=4:
3             =head1 NAME
4              
5             CPAN::Mirrors - Get CPAN mirror information and select a fast one
6              
7             =head1 SYNOPSIS
8              
9             use CPAN::Mirrors;
10              
11             my $mirrors = CPAN::Mirrors->new( $mirrored_by_file );
12              
13             my $seen = {};
14              
15             my $best_continent = $mirrors->find_best_continents( { seen => $seen } );
16             my @mirrors = $mirrors->get_mirrors_by_continents( $best_continent );
17              
18             my $callback = sub {
19             my( $m ) = @_;
20             printf "%s = %s\n", $m->hostname, $m->rtt
21             };
22             $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback, %args );
23              
24             @mirrors = sort { $a->rtt <=> $b->rtt } @mirrors;
25              
26             print "Best mirrors are ", map( { $_->rtt } @mirrors[0..3] ), "\n";
27              
28             =head1 DESCRIPTION
29              
30             =over
31              
32             =cut
33              
34             package CPAN::Mirrors;
35 4     4   43 use strict;
  4         9  
  4         181  
36 4     4   26 use vars qw($VERSION $urllist $silent);
  4         11  
  4         362  
37             $VERSION = "2.27";
38              
39 4     4   30 use Carp;
  4         15  
  4         357  
40 4     4   27 use FileHandle;
  4         14  
  4         60  
41 4     4   1954 use Fcntl ":flock";
  4         8  
  4         530  
42 4     4   3043 use Net::Ping ();
  4         96253  
  4         147  
43 4     4   1010 use CPAN::Version;
  4         10  
  4         11117  
44              
45             =item new( LOCAL_FILE_NAME )
46              
47             Create a new CPAN::Mirrors object from LOCAL_FILE_NAME. This file
48             should look like that in http://www.cpan.org/MIRRORED.BY .
49              
50             =cut
51              
52             sub new {
53 0     0 1 0 my ($class, $file) = @_;
54 0 0       0 croak "CPAN::Mirrors->new requires a filename" unless defined $file;
55 0 0       0 croak "The file [$file] was not found" unless -e $file;
56              
57 0         0 my $self = bless {
58             mirrors => [],
59             geography => {},
60             }, $class;
61              
62 0         0 $self->parse_mirrored_by( $file );
63              
64 0         0 return $self;
65             }
66              
67             sub parse_mirrored_by {
68 0     0 0 0 my ($self, $file) = @_;
69 0         0 my $handle = FileHandle->new;
70 0 0       0 $handle->open($file)
71             or croak "Couldn't open $file: $!";
72 0         0 flock $handle, LOCK_SH;
73 0         0 $self->_parse($file,$handle);
74 0         0 flock $handle, LOCK_UN;
75 0         0 $handle->close;
76             }
77              
78             =item continents()
79              
80             Return a list of continents based on those defined in F.
81              
82             =cut
83              
84             sub continents {
85 0     0 1 0 my ($self) = @_;
86 0 0       0 return sort keys %{$self->{geography} || {}};
  0         0  
87             }
88              
89             =item countries( [CONTINENTS] )
90              
91             Return a list of countries based on those defined in F.
92             It only returns countries for the continents you specify (as defined
93             in C). If you don't specify any continents, it returns all
94             of the countries listed in F.
95              
96             =cut
97              
98             sub countries {
99 0     0 1 0 my ($self, @continents) = @_;
100 0 0       0 @continents = $self->continents unless @continents;
101 0         0 my @countries;
102 0         0 for my $c (@continents) {
103 0 0       0 push @countries, sort keys %{ $self->{geography}{$c} || {} };
  0         0  
104             }
105 0         0 return @countries;
106             }
107              
108             =item mirrors( [COUNTRIES] )
109              
110             Return a list of mirrors based on those defined in F.
111             It only returns mirrors for the countries you specify (as defined
112             in C). If you don't specify any countries, it returns all
113             of the mirrors listed in F.
114              
115             =cut
116              
117             sub mirrors {
118 0     0 1 0 my ($self, @countries) = @_;
119 0 0       0 return @{$self->{mirrors}} unless @countries;
  0         0  
120 0         0 my %wanted = map { $_ => 1 } @countries;
  0         0  
121 0         0 my @found;
122 0         0 for my $m (@{$self->{mirrors}}) {
  0         0  
123 0 0       0 push @found, $m if exists $wanted{$m->country};
124             }
125 0         0 return @found;
126             }
127              
128             =item get_mirrors_by_countries( [COUNTRIES] )
129              
130             A more sensible synonym for mirrors.
131              
132             =cut
133              
134 0     0 1 0 sub get_mirrors_by_countries { &mirrors }
135              
136             =item get_mirrors_by_continents( [CONTINENTS] )
137              
138             Return a list of mirrors for all of continents you specify. If you don't
139             specify any continents, it returns all of the mirrors.
140              
141             You can specify a single continent or an array reference of continents.
142              
143             =cut
144              
145             sub get_mirrors_by_continents {
146 0     0 1 0 my ($self, $continents ) = @_;
147 0 0       0 $continents = [ $continents ] unless ref $continents;
148              
149 0         0 eval {
150 0         0 $self->mirrors( $self->get_countries_by_continents( @$continents ) );
151             };
152             }
153              
154             =item get_countries_by_continents( [CONTINENTS] )
155              
156             A more sensible synonym for countries.
157              
158             =cut
159              
160 0     0 1 0 sub get_countries_by_continents { &countries }
161              
162             =item default_mirror
163              
164             Returns the default mirror, http://www.cpan.org/ . This mirror uses
165             dynamic DNS to give a close mirror.
166              
167             =cut
168              
169             sub default_mirror {
170 0     0 1 0 CPAN::Mirrored::By->new({ http => 'http://www.cpan.org/'});
171             }
172              
173             =item best_mirrors
174              
175             C checks for the best mirrors based on the list of
176             continents you pass, or, without that, all continents, as defined
177             by C. It pings each mirror, up to the value of
178             C. In list context, it returns up to C mirrors.
179             In scalar context, it returns the single best mirror.
180              
181             Arguments
182              
183             how_many - the number of mirrors to return. Default: 1
184             callback - a callback for find_best_continents
185             verbose - true or false on all the whining and moaning. Default: false
186             continents - an array ref of the continents to check
187             external_ping - if true, use external ping via Net::Ping::External. Default: false
188              
189             If you don't specify the continents, C calls
190             C to get the list of continents to check.
191              
192             If you don't have L v2.13 or later, needed for timings,
193             this returns the default mirror.
194              
195             C should be set and then C needs
196             to be installed, if the local network has a transparent proxy.
197              
198             =cut
199              
200             sub best_mirrors {
201 0     0 1 0 my ($self, %args) = @_;
202 0   0     0 my $how_many = $args{how_many} || 1;
203 0         0 my $callback = $args{callback};
204 0 0       0 my $verbose = defined $args{verbose} ? $args{verbose} : 0;
205 0   0     0 my $continents = $args{continents} || [];
206 0 0       0 $continents = [$continents] unless ref $continents;
207 0 0       0 $args{external_ping} = 0 unless defined $args{external_ping};
208 0         0 my $external_ping = $args{external_ping};
209              
210             # Old Net::Ping did not do timings at all
211 0         0 my $min_version = '2.13';
212 0 0       0 unless( CPAN::Version->vgt(Net::Ping->VERSION, $min_version) ) {
213 0         0 carp sprintf "Net::Ping version is %s (< %s). Returning %s",
214             Net::Ping->VERSION, $min_version, $self->default_mirror;
215 0         0 return $self->default_mirror;
216             }
217              
218 0         0 my $seen = {};
219              
220 0 0       0 if ( ! @$continents ) {
221 0 0       0 print "Searching for the best continent ...\n" if $verbose;
222 0         0 my @best_continents = $self->find_best_continents(
223             seen => $seen,
224             verbose => $verbose,
225             callback => $callback,
226             external_ping => $external_ping,
227             );
228              
229             # Only add enough continents to find enough mirrors
230 0         0 my $count = 0;
231 0         0 for my $continent ( @best_continents ) {
232 0         0 push @$continents, $continent;
233 0         0 $count += $self->mirrors( $self->countries($continent) );
234 0 0       0 last if $count >= $how_many;
235             }
236             }
237              
238 0 0       0 return $self->default_mirror unless @$continents;
239 0 0       0 print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose;
240              
241 0         0 my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] );
242              
243 0         0 my $timings = $self->get_mirrors_timings(
244             $trial_mirrors,
245             $seen,
246             $callback,
247             %args,
248             );
249 0 0       0 return $self->default_mirror unless @$timings;
250              
251 0 0       0 $how_many = @$timings if $how_many > @$timings;
252              
253 0 0       0 return wantarray ? @{$timings}[0 .. $how_many-1] : $timings->[0];
  0         0  
254             }
255              
256             =item get_n_random_mirrors_by_continents( N, [CONTINENTS] )
257              
258             Returns up to N random mirrors for the specified continents. Specify the
259             continents as an array reference.
260              
261             =cut
262              
263             sub get_n_random_mirrors_by_continents {
264 0     0 1 0 my( $self, $n, $continents ) = @_;
265 0   0     0 $n ||= 3;
266 0 0       0 $continents = [ $continents ] unless ref $continents;
267              
268 0 0       0 if ( $n <= 0 ) {
269 0 0       0 return wantarray ? () : [];
270             }
271              
272 0         0 my @long_list = $self->get_mirrors_by_continents( $continents );
273              
274 0 0 0     0 if ( $n eq '*' or $n > @long_list ) {
275 0 0       0 return wantarray ? @long_list : \@long_list;
276             }
277              
278 0         0 @long_list = map {$_->[0]}
279 0         0 sort {$a->[1] <=> $b->[1]}
280 0         0 map {[$_, rand]} @long_list;
  0         0  
281              
282 0         0 splice @long_list, $n; # truncate
283              
284 0         0 \@long_list;
285             }
286              
287             =item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK, %ARGS );
288              
289             Pings the listed mirrors and returns a list of mirrors sorted in
290             ascending ping times.
291              
292             C is an anonymous array of C objects to
293             ping.
294              
295             The optional argument C is a hash reference used to track the
296             mirrors you've already pinged.
297              
298             The optional argument C is a subroutine reference to call
299             after each ping. It gets the C object after each
300             ping.
301              
302             =cut
303              
304             sub get_mirrors_timings {
305 0     0 1 0 my( $self, $mirror_list, $seen, $callback, %args ) = @_;
306              
307 0 0       0 $seen = {} unless defined $seen;
308 0 0       0 croak "The mirror list argument must be an array reference"
309             unless ref $mirror_list eq ref [];
310 0 0       0 croak "The seen argument must be a hash reference"
311             unless ref $seen eq ref {};
312             croak "callback must be a subroutine"
313 0 0 0 0   0 if( defined $callback and ref $callback ne ref sub {} );
314              
315 0         0 my $timings = [];
316 0         0 for my $m ( @$mirror_list ) {
317 0         0 $seen->{$m->hostname} = $m;
318 0 0       0 next unless eval{ $m->http };
  0         0  
319              
320 0 0       0 if( $self->_try_a_ping( $seen, $m, ) ) {
321 0         0 my $ping = $m->ping(%args);
322 0 0       0 next unless defined $ping;
323             # printf "m %s ping %s\n", $m, $ping;
324 0         0 push @$timings, $m;
325 0 0       0 $callback->( $m ) if $callback;
326             }
327             else {
328             push @$timings, $seen->{$m->hostname}
329 0 0       0 if defined $seen->{$m->hostname}->rtt;
330             }
331             }
332              
333             my @best = sort {
334 0 0 0     0 if( defined $a->rtt and defined $b->rtt ) {
  0 0 0     0  
    0 0        
    0 0        
335 0         0 $a->rtt <=> $b->rtt
336             }
337             elsif( defined $a->rtt and ! defined $b->rtt ) {
338 0         0 return -1;
339             }
340             elsif( ! defined $a->rtt and defined $b->rtt ) {
341 0         0 return 1;
342             }
343             elsif( ! defined $a->rtt and ! defined $b->rtt ) {
344 0         0 return 0;
345             }
346              
347             } @$timings;
348              
349 0 0       0 return wantarray ? @best : \@best;
350             }
351              
352             =item find_best_continents( HASH_REF );
353              
354             C goes through each continent and pings C
355             random mirrors on that continent. It then orders the continents by
356             ascending median ping time. In list context, it returns the ordered list
357             of continent. In scalar context, it returns the same list as an
358             anonymous array.
359              
360             Arguments:
361              
362             n - the number of hosts to ping for each continent. Default: 3
363             seen - a hashref of cached hostname ping times
364             verbose - true or false for noisy or quiet. Default: false
365             callback - a subroutine to run after each ping.
366             ping_cache_limit - how long, in seconds, to reuse previous ping times.
367             Default: 1 day
368              
369             The C hash has hostnames as keys and anonymous arrays as values.
370             The anonymous array is a triplet of a C object, a
371             ping time, and the epoch time for the measurement.
372              
373             The callback subroutine gets the C object, the ping
374             time, and measurement time (the same things in the C hashref) as
375             arguments. C doesn't care what the callback does
376             and ignores the return value.
377              
378             With a low value for C, a single mirror might skew the results enough
379             to choose a worse continent. If you have that problem, try a larger
380             value.
381              
382             =cut
383              
384             sub find_best_continents {
385 0     0 1 0 my ($self, %args) = @_;
386              
387 0   0     0 $args{n} ||= 3;
388 0 0       0 $args{verbose} = 0 unless defined $args{verbose};
389 0 0       0 $args{seen} = {} unless defined $args{seen};
390             croak "The seen argument must be a hash reference"
391 0 0       0 unless ref $args{seen} eq ref {};
392             $args{ping_cache_limit} = 24 * 60 * 60
393 0 0       0 unless defined $args{ping_cache_limit};
394             croak "callback must be a subroutine"
395 0 0 0 0   0 if( defined $args{callback} and ref $args{callback} ne ref sub {} );
396              
397 0         0 my %medians;
398 0         0 CONT: for my $c ( $self->continents ) {
399 0         0 my @mirrors = $self->mirrors( $self->countries($c) );
400             printf "Testing %s (%d mirrors)\n", $c, scalar @mirrors
401 0 0       0 if $args{verbose};
402              
403 0 0       0 next CONT unless @mirrors;
404 0 0       0 my $n = (@mirrors < $args{n}) ? @mirrors : $args{n};
405              
406 0         0 my @tests;
407 0         0 my $tries = 0;
408 0   0     0 RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) {
      0        
409 0         0 my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
410 0 0       0 if( $self->_try_a_ping(
411             $args{seen}, $m, $args{ping_cache_limit}
412             )) {
413             $self->get_mirrors_timings(
414             [ $m ],
415             $args{seen},
416             $args{callback},
417 0         0 %args,
418             );
419 0 0       0 next RANDOM unless defined $args{seen}{$m->hostname}->rtt;
420             }
421             printf "(%s -> %0.2f ms)",
422             $m->hostname,
423             join ' ', 1000 * $args{seen}{$m->hostname}->rtt
424 0 0       0 if $args{verbose};
425              
426 0         0 push @tests, $args{seen}{$m->hostname}->rtt;
427             }
428              
429 0         0 my $median = $self->_get_median_ping_time( \@tests, $args{verbose} );
430 0 0       0 $medians{$c} = $median if defined $median;
431             }
432              
433 0         0 my @best_cont = sort { $medians{$a} <=> $medians{$b} } keys %medians;
  0         0  
434              
435 0 0       0 if ( $args{verbose} ) {
436 0         0 print "Median result by continent:\n";
437 0 0       0 if ( @best_cont ) {
438 0         0 for my $c ( @best_cont ) {
439 0         0 printf( " %7.2f ms %s\n", $medians{$c}*1000, $c );
440             }
441             } else {
442 0         0 print " **** No results found ****\n"
443             }
444             }
445              
446 0 0       0 return wantarray ? @best_cont : $best_cont[0];
447             }
448              
449             # retry if
450             sub _try_a_ping {
451 0     0   0 my ($self, $seen, $mirror, $ping_cache_limit ) = @_;
452              
453             ( ! exists $seen->{$mirror->hostname}
454             or
455             ! defined $seen->{$mirror->hostname}->rtt
456             or
457             ! defined $ping_cache_limit
458             or
459 0 0 0     0 time - $seen->{$mirror->hostname}->ping_time
460             > $ping_cache_limit
461             )
462             }
463              
464             sub _get_median_ping_time {
465 0     0   0 my ($self, $tests, $verbose ) = @_;
466              
467 0         0 my @sorted = sort { $a <=> $b } @$tests;
  0         0  
468              
469 0         0 my $median = do {
470 0 0       0 if ( @sorted == 0 ) { undef }
  0 0       0  
    0          
471 0         0 elsif ( @sorted == 1 ) { $sorted[0] }
472 0         0 elsif ( @sorted % 2 ) { $sorted[ int(@sorted / 2) ] }
473             else {
474 0         0 my $mid_high = int(@sorted/2);
475 0         0 ($sorted[$mid_high-1] + $sorted[$mid_high])/2;
476             }
477             };
478              
479 0 0       0 if ($verbose){
480 0 0       0 if ($median) {
481 0         0 printf " => median time: %.2f ms\n", $median * 1000
482             } else {
483 0         0 printf " => **** no median time ****\n";
484             }
485             }
486              
487 0         0 return $median;
488             }
489              
490             # Adapted from Parse::CPAN::MirroredBy by Adam Kennedy
491             sub _parse {
492 0     0   0 my ($self, $file, $handle) = @_;
493 0         0 my $output = $self->{mirrors};
494 0         0 my $geo = $self->{geography};
495              
496 0         0 local $/ = "\012";
497 0         0 my $line = 0;
498 0         0 my $mirror = undef;
499 0         0 while ( 1 ) {
500             # Next line
501 0         0 my $string = <$handle>;
502 0 0       0 last if ! defined $string;
503 0         0 $line = $line + 1;
504              
505             # Remove the useless lines
506 0         0 chomp( $string );
507 0 0       0 next if $string =~ /^\s*$/;
508 0 0       0 next if $string =~ /^\s*#/;
509              
510             # Hostname or property?
511 0 0       0 if ( $string =~ /^\s/ ) {
512             # Property
513 0 0       0 unless ( $string =~ /^\s+(\w+)\s+=\s+\"(.*)\"$/ ) {
514 0         0 croak("Invalid property on line $line");
515             }
516 0         0 my ($prop, $value) = ($1,$2);
517 0   0     0 $mirror ||= {};
518 0 0       0 if ( $prop eq 'dst_location' ) {
    0          
    0          
    0          
519 0         0 my (@location,$continent,$country);
520 0 0       0 @location = (split /\s*,\s*/, $value)
521             and ($continent, $country) = @location[-1,-2];
522 0         0 $continent =~ s/\s\(.*//;
523 0         0 $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude
524 0 0 0     0 $geo->{$continent}{$country} = 1 if $continent && $country;
525 0   0     0 $mirror->{continent} = $continent || "unknown";
526 0   0     0 $mirror->{country} = $country || "unknown";
527             }
528             elsif ( $prop eq 'dst_http' ) {
529 0         0 $mirror->{http} = $value;
530             }
531             elsif ( $prop eq 'dst_ftp' ) {
532 0         0 $mirror->{ftp} = $value;
533             }
534             elsif ( $prop eq 'dst_rsync' ) {
535 0         0 $mirror->{rsync} = $value;
536             }
537             else {
538 0         0 $prop =~ s/^dst_//;
539 0         0 $mirror->{$prop} = $value;
540             }
541             } else {
542             # Hostname
543 0 0       0 unless ( $string =~ /^([\w\.-]+)\:\s*$/ ) {
544 0         0 croak("Invalid host name on line $line");
545             }
546 0         0 my $current = $mirror;
547 0         0 $mirror = { hostname => "$1" };
548 0 0       0 if ( $current ) {
549 0         0 push @$output, CPAN::Mirrored::By->new($current);
550             }
551             }
552             }
553 0 0       0 if ( $mirror ) {
554 0         0 push @$output, CPAN::Mirrored::By->new($mirror);
555             }
556              
557 0         0 return;
558             }
559              
560             #--------------------------------------------------------------------------#
561              
562             package CPAN::Mirrored::By;
563 4     4   44 use strict;
  4         10  
  4         162  
564 4     4   27 use Net::Ping ();
  4         8  
  4         2016  
565              
566             sub new {
567 1     1   1009 my($self,$arg) = @_;
568 1   50     5 $arg ||= {};
569 1         2 bless $arg, $self;
570             }
571 0     0   0 sub hostname { shift->{hostname} }
572 1     1   379 sub continent { shift->{continent} }
573 1     1   5 sub country { shift->{country} }
574 0 0   0   0 sub http { shift->{http} || '' }
575 0 0   0   0 sub ftp { shift->{ftp} || '' }
576 0 0   0   0 sub rsync { shift->{rsync} || '' }
577 0     0   0 sub rtt { shift->{rtt} }
578 0     0   0 sub ping_time { shift->{ping_time} }
579              
580             sub url {
581 1     1   2 my $self = shift;
582 1   33     7 return $self->{http} || $self->{ftp};
583             }
584              
585             sub ping {
586 0     0     my($self, %args) = @_;
587              
588 0           my $external_ping = $args{external_ping};
589 0 0         if ($external_ping) {
590 0 0         eval { require Net::Ping::External }
  0            
591             or die "Net::Ping::External required to use external ping command";
592             }
593 0 0         my $ping = Net::Ping->new(
    0          
594             $external_ping ? 'external' : $^O eq 'VMS' ? 'icmp' : 'tcp',
595             1
596             );
597 0           my ($proto) = $self->url =~ m{^([^:]+)};
598 0 0         my $port = $proto eq 'http' ? 80 : 21;
599 0 0         return unless $port;
600              
601 0 0         if ( $ping->can('port_number') ) {
602 0           $ping->port_number($port);
603             }
604             else {
605 0           $ping->{'port_num'} = $port;
606             }
607              
608 0 0         $ping->hires(1) if $ping->can('hires');
609 0           my ($alive,$rtt) = eval { $ping->ping($self->hostname); };
  0            
610 0           my $verbose = $args{verbose};
611 0 0 0       if ($verbose && !$alive) {
612 0           printf "(host %s not alive)", $self->hostname;
613             }
614              
615 0 0         $self->{rtt} = $alive ? $rtt : undef;
616 0           $self->{ping_time} = time;
617              
618 0           $self->rtt;
619             }
620              
621              
622             1;
623              
624             =back
625              
626             =head1 AUTHOR
627              
628             Andreas Koenig C<< >>, David Golden C<< >>,
629             brian d foy C<< >>
630              
631             =head1 LICENSE
632              
633             This program is free software; you can redistribute it and/or
634             modify it under the same terms as Perl itself.
635              
636             See L
637              
638             =cut