Commit | Line | Data |
0124e695 |
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); |
49ded548 |
6 | $VERSION = "1.770001"; # 1.77 + local patches for bleadperl |
0124e695 |
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))) { |
0100440d |
86 | next unless $m->ftp; |
0124e695 |
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; |
0100440d |
243 | return $self->{ftp} || $self->{http}; |
0124e695 |
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 | |