cpan/CPAN/lib/CPAN/Mirrors.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 # vim: ts=4 sts=4 sw=4:
   3 package CPAN::Mirrors;
   4 use strict;
   5 use vars qw($VERSION $urllist $silent);
   6 $VERSION = "1.770001"; # 1.77 + local patches for bleadperl
   7
   8 use Carp;
   9 use FileHandle;
  10 use Fcntl ":flock";
  11
  12 sub new {
  13     my ($class, $file) = @_;
  14     my $self = bless {
  15         mirrors => [],
  16         geography => {},
  17     }, $class;
  18
  19     my $handle = FileHandle->new;
  20     $handle->open($file)
  21         or croak "Couldn't open $file: $!";
  22     flock $handle, LOCK_SH;
  23     $self->_parse($file,$handle);
  24     flock $handle, LOCK_UN;
  25     $handle->close;
  26
  27     # populate continents & countries
  28
  29     return $self
  30 }
  31
  32 sub continents {
  33     my ($self) = @_;
  34     return keys %{$self->{geography}};
  35 }
  36
  37 sub countries {
  38     my ($self, @continents) = @_;
  39     @continents = $self->continents unless @continents;
  40     my @countries;
  41     for my $c (@continents) {
  42         push @countries, keys %{ $self->{geography}{$c} };
  43     }
  44     return @countries;
  45 }
  46
  47 sub mirrors {
  48     my ($self, @countries) = @_;
  49     return @{$self->{mirrors}} unless @countries;
  50     my %wanted = map { $_ => 1 } @countries;
  51     my @found;
  52     for my $m (@{$self->{mirrors}}) {
  53         push @found, $m if exists $wanted{$m->country};
  54     }
  55     return @found;
  56 }
  57
  58 sub best_mirrors {
  59     my ($self, %args) = @_;
  60     my $how_many = $args{how_many} || 1;
  61     my $callback = $args{callback};
  62     my $verbose = $args{verbose};
  63     my $conts = $args{continents} || [];
  64     $conts = [$conts] unless ref $conts;
  65
  66     my $seen = {};
  67
  68     if ( ! @$conts ) {
  69         print "Searching for the best continent ...\n" if $verbose;
  70         my @best = $self->_find_best_continent($seen, $verbose, $callback);
  71
  72         # how many continents to find enough mirrors? We should scan
  73         # more than we need -- arbitrarily, we'll say x2
  74         my $count = 0;
  75         for my $c ( @best ) {
  76             push @$conts, $c;
  77             $count += $self->mirrors( $self->countries($c) );
  78             last if $count >= 2 * $how_many;
  79         }
  80     }
  81
  82     print "Scanning " . join(", ", @$conts) . " ...\n" if $verbose;
  83
  84     my @timings;
  85     for my $m ($self->mirrors($self->countries(@$conts))) {
  86         next unless $m->ftp;
  87         my $hostname = $m->hostname;
  88         if ( $seen->{$hostname}  ) {
  89             push @timings, $seen->{$hostname}
  90                 if defined $seen->{$hostname}[1];
  91         }
  92         else {
  93             my $ping = $m->ping;
  94             next unless defined $ping;
  95             push @timings, [$m, $ping];
  96             $callback->($m,$ping) if $callback;
  97         }
  98     }
  99     return unless @timings;
 100     $how_many = @timings if $how_many > @timings;
 101     my @best =
 102         map  { $_->[0] }
 103         sort { $a->[1] <=> $b->[1] } @timings;
 104
 105     return wantarray ? @best[0 .. $how_many-1] : $best[0];
 106 }
 107
 108 sub _find_best_continent {
 109     my ($self, $seen, $verbose, $callback) = @_;
 110
 111     my %median;
 112     CONT: for my $c ( $self->continents ) {
 113         my @mirrors = $self->mirrors( $self->countries($c) );
 114         next CONT unless @mirrors;
 115         my $sample = 9;
 116         my $n = (@mirrors < $sample) ? @mirrors : $sample;
 117         my @tests;
 118         RANDOM: while ( @mirrors && @tests < $n ) {
 119             my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
 120             my $ping = $m->ping;
 121             $callback->($m,$ping) if $callback;
 122             # record undef so we don't try again
 123             $seen->{$m->hostname} = [$m, $ping];
 124             next RANDOM unless defined $ping;
 125             push @tests, $ping;
 126         }
 127         next CONT unless @tests;
 128         @tests = sort { $a <=> $b } @tests;
 129         if ( @tests == 1 ) {
 130             $median{$c} = $tests[0];
 131         }
 132         elsif ( @tests % 2 ) {
 133             $median{$c} = $tests[ int(@tests / 2) ];
 134         }
 135         else {
 136             my $mid_high = int(@tests/2);
 137             $median{$c} = ($tests[$mid_high-1] + $tests[$mid_high])/2;
 138         }
 139     }
 140
 141     my @best_cont = sort { $median{$a} <=> $median{$b} } keys %median ;
 142
 143     if ( $verbose ) {
 144         print "Median result by continent:\n";
 145         for my $c ( @best_cont ) {
 146             printf( "  %d ms  %s\n", int($median{$c}*1000+.5), $c );
 147         }
 148     }
 149
 150     return wantarray ? @best_cont : $best_cont[0];
 151 }
 152
 153 # Adapted from Parse::CPAN::MirroredBy by Adam Kennedy
 154 sub _parse {
 155     my ($self, $file, $handle) = @_;
 156     my $output = $self->{mirrors};
 157     my $geo = $self->{geography};
 158
 159     local $/ = "\012";
 160     my $line = 0;
 161     my $mirror = undef;
 162     while ( 1 ) {
 163         # Next line
 164         my $string = <$handle>;
 165         last if ! defined $string;
 166         $line = $line + 1;
 167
 168         # Remove the useless lines
 169         chomp( $string );
 170         next if $string =~ /^\s*$/;
 171         next if $string =~ /^\s*#/;
 172
 173         # Hostname or property?
 174         if ( $string =~ /^\s/ ) {
 175             # Property
 176             unless ( $string =~ /^\s+(\w+)\s+=\s+\"(.*)\"$/ ) {
 177                 croak("Invalid property on line $line");
 178             }
 179             my ($prop, $value) = ($1,$2);
 180             $mirror ||= {};
 181             if ( $prop eq 'dst_location' ) {
 182                 my (@location,$continent,$country);
 183                 @location = (split /\s*,\s*/, $value)
 184                     and ($continent, $country) = @location[-1,-2];
 185                 $continent =~ s/\s\(.*//;
 186                 $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude
 187                 $geo->{$continent}{$country} = 1 if $continent && $country;
 188                 $mirror->{continent} = $continent || "unknown";
 189                 $mirror->{country} = $country || "unknown";
 190             }
 191             elsif ( $prop eq 'dst_http' ) {
 192                 $mirror->{http} = $value;
 193             }
 194             elsif ( $prop eq 'dst_ftp' ) {
 195                 $mirror->{ftp} = $value;
 196             }
 197             elsif ( $prop eq 'dst_rsync' ) {
 198                 $mirror->{rsync} = $value;
 199             }
 200             else {
 201                 $prop =~ s/^dst_//;
 202                 $mirror->{$prop} = $value;
 203             }
 204         } else {
 205             # Hostname
 206             unless ( $string =~ /^([\w\.-]+)\:\s*$/ ) {
 207                 croak("Invalid host name on line $line");
 208             }
 209             my $current = $mirror;
 210             $mirror     = { hostname => "$1" };
 211             if ( $current ) {
 212                 push @$output, CPAN::Mirrored::By->new($current);
 213             }
 214         }
 215     }
 216     if ( $mirror ) {
 217         push @$output, CPAN::Mirrored::By->new($mirror);
 218     }
 219
 220     return;
 221 }
 222
 223 #--------------------------------------------------------------------------#
 224
 225 package CPAN::Mirrored::By;
 226 use strict;
 227 use Net::Ping   ();
 228
 229 sub new {
 230     my($self,$arg) = @_;
 231     $arg ||= {};
 232     bless $arg, $self;
 233 }
 234 sub hostname { shift->{hostname} }
 235 sub continent { shift->{continent} }
 236 sub country { shift->{country} }
 237 sub http { shift->{http} || '' }
 238 sub ftp { shift->{ftp} || '' }
 239 sub rsync { shift->{rsync} || '' }
 240
 241 sub url {
 242     my $self = shift;
 243     return $self->{ftp} || $self->{http};
 244 }
 245
 246 sub ping {
 247     my $self = shift;
 248     my $ping = Net::Ping->new("tcp",1);
 249     my ($proto) = $self->url =~ m{^([^:]+)};
 250     my $port = $proto eq 'http' ? 80 : 21;
 251     return unless $port;
 252     $ping->port_number($port);
 253     $ping->hires(1);
 254     my ($alive,$rtt) = $ping->ping($self->hostname);
 255     return $alive ? $rtt : undef;
 256 }
 257
 258
 259 1;
 260