File Coverage

blib/lib/CPAN/Mirrors.pm
Criterion Covered Total %
statement 31 238 13.0
branch 0 156 0.0
condition 2 52 3.8
subroutine 12 37 32.4
pod 12 13 92.3
total 57 496 11.4


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