line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Mirror::YAML; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
28998
|
use 5.005; |
|
2
|
|
|
|
|
10
|
|
|
2
|
|
|
|
|
197
|
|
4
|
2
|
|
|
2
|
|
12
|
use strict; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
73
|
|
5
|
2
|
|
|
2
|
|
1940
|
use Params::Util qw{_STRING _POSINT _ARRAY0 _INSTANCE }; |
|
2
|
|
|
|
|
9958
|
|
|
2
|
|
|
|
|
181
|
|
6
|
2
|
|
|
2
|
|
2342
|
use YAML::Tiny (); |
|
2
|
|
|
|
|
13576
|
|
|
2
|
|
|
|
|
51
|
|
7
|
2
|
|
|
2
|
|
2170
|
use URI (); |
|
2
|
|
|
|
|
11668
|
|
|
2
|
|
|
|
|
48
|
|
8
|
2
|
|
|
2
|
|
2408
|
use Time::HiRes (); |
|
2
|
|
|
|
|
4236
|
|
|
2
|
|
|
|
|
69
|
|
9
|
2
|
|
|
2
|
|
2436
|
use Time::Local (); |
|
2
|
|
|
|
|
3728
|
|
|
2
|
|
|
|
|
49
|
|
10
|
2
|
|
|
2
|
|
1788
|
use LWP::Simple (); |
|
2
|
|
|
|
|
142496
|
|
|
2
|
|
|
|
|
58
|
|
11
|
2
|
|
|
2
|
|
1426
|
use Mirror::YAML::URI (); |
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
44
|
|
12
|
|
|
|
|
|
|
|
13
|
2
|
|
|
2
|
|
13
|
use constant ONE_DAY => 86700; # 1 day plus 5 minutes fudge factor |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
134
|
|
14
|
2
|
|
|
2
|
|
10
|
use constant TWO_DAYS => 172800; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
86
|
|
15
|
2
|
|
|
2
|
|
11
|
use constant THIRTY_DAYS => 2592000; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
86
|
|
16
|
|
|
|
|
|
|
|
17
|
2
|
|
|
2
|
|
10
|
use vars qw{$VERSION}; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
76
|
|
18
|
|
|
|
|
|
|
BEGIN { |
19
|
2
|
|
|
2
|
|
2612
|
$VERSION = '0.03'; |
20
|
|
|
|
|
|
|
} |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
##################################################################### |
27
|
|
|
|
|
|
|
# Wrapper for the YAML::Tiny methods |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
sub new { |
30
|
1
|
|
|
1
|
0
|
3
|
my $class = shift; |
31
|
1
|
|
|
|
|
6
|
my $self = bless { @_ }, $class; |
32
|
1
|
50
|
|
|
|
15
|
if ( _STRING($self->{uri}) ) { |
33
|
1
|
|
|
|
|
11
|
$self->{uri} = URI->new($self->{uri}); |
34
|
|
|
|
|
|
|
} |
35
|
1
|
50
|
33
|
|
|
10595
|
if ( _STRING($self->{timestamp}) and ! _POSINT($self->{timestamp}) ) { |
36
|
1
|
50
|
|
|
|
27
|
unless ( $self->{timestamp} =~ /^(\d\d\d\d)-(\d\d)-(\d\d)T(\d\d):(\d\d):(\d\d)Z$/ ) { |
37
|
0
|
|
|
|
|
0
|
return undef; |
38
|
|
|
|
|
|
|
} |
39
|
1
|
|
|
|
|
13
|
$self->{timestamp} = Time::Local::timegm( $6, $5, $4, $3, $2 - 1, $1 ); |
40
|
|
|
|
|
|
|
} |
41
|
1
|
50
|
|
|
|
54
|
unless ( _ARRAY0($self->{mirrors}) ) { |
42
|
0
|
|
|
|
|
0
|
return undef; |
43
|
|
|
|
|
|
|
} |
44
|
1
|
|
|
|
|
2
|
foreach ( @{$self->{mirrors}} ) { |
|
1
|
|
|
|
|
4
|
|
45
|
14
|
50
|
|
|
|
53
|
if ( _STRING($_->{uri}) ) { |
46
|
14
|
|
|
|
|
42
|
$_->{uri} = URI->new($_->{uri}); |
47
|
14
|
50
|
|
|
|
678
|
$_ = Mirror::YAML::URI->new( %$_ ) or return undef; |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
} |
50
|
1
|
|
|
|
|
19
|
return $self; |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
sub read { |
54
|
1
|
|
|
1
|
0
|
832
|
my $class = shift; |
55
|
1
|
|
|
|
|
11
|
my $yaml = YAML::Tiny->read( @_ ); |
56
|
1
|
|
|
|
|
8561
|
$class->new( %{ $yaml->[0] } ); |
|
1
|
|
|
|
|
13
|
|
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub read_string { |
60
|
0
|
|
|
0
|
0
|
0
|
my $class = shift; |
61
|
0
|
|
|
|
|
0
|
my $yaml = YAML::Tiny->read_string( @_ ); |
62
|
0
|
|
|
|
|
0
|
$class->new( %{ $yaml->[0] } ); |
|
0
|
|
|
|
|
0
|
|
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
sub write { |
66
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
67
|
0
|
|
|
|
|
0
|
$self->as_yaml_tiny->write( @_ ); |
68
|
|
|
|
|
|
|
} |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
sub write_string { |
71
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
72
|
0
|
|
|
|
|
0
|
$self->as_yaml_tiny->write_string( @_ ); |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
sub as_yaml_tiny { |
76
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
77
|
0
|
|
|
|
|
0
|
my $yaml = YAML::Tiny->( { %$self } ); |
78
|
0
|
0
|
|
|
|
0
|
if ( defined $yaml->{source} ) { |
79
|
0
|
|
|
|
|
0
|
$yaml->{source} = "$yaml->{source}"; |
80
|
|
|
|
|
|
|
} |
81
|
0
|
|
|
|
|
0
|
$yaml; |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
##################################################################### |
89
|
|
|
|
|
|
|
# Mirror::YAML Methods |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
sub name { |
92
|
1
|
|
|
1
|
0
|
688
|
$_[0]->{name}; |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
sub uri { |
96
|
2
|
|
|
2
|
0
|
11
|
$_[0]->{uri}; |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
sub timestamp { |
100
|
1
|
|
|
1
|
0
|
5
|
$_[0]->{timestamp}; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
sub age { |
104
|
1
|
50
|
|
1
|
0
|
20
|
$_[0]->{age} or time - $_[0]->{timestamp}; |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
sub benchmark { |
108
|
0
|
|
|
0
|
0
|
0
|
$_[0]->{benchmark}; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
sub mirrors { |
112
|
3
|
|
|
3
|
0
|
6
|
@{ $_[0]->{mirrors} }; |
|
3
|
|
|
|
|
18
|
|
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
##################################################################### |
120
|
|
|
|
|
|
|
# Main Methods |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sub check_mirrors { |
123
|
2
|
|
|
2
|
0
|
5
|
my $self = shift; |
124
|
2
|
|
|
|
|
11
|
foreach my $mirror ( $self->mirrors ) { |
125
|
28
|
100
|
|
|
|
91
|
next if defined $mirror->{live}; |
126
|
14
|
|
|
|
|
66
|
$mirror->get; |
127
|
|
|
|
|
|
|
} |
128
|
2
|
|
|
|
|
10
|
return 1; |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
# Does the mirror with the newest timestamp newer than ours |
132
|
|
|
|
|
|
|
# have a different master? If so, update our master server. |
133
|
|
|
|
|
|
|
# This lets us survive major reorgansations, as long as some |
134
|
|
|
|
|
|
|
# of the existing mirrors are retained. |
135
|
|
|
|
|
|
|
sub check_master { |
136
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
# Make sure we have checked the mirrors |
139
|
0
|
|
|
|
|
0
|
$self->check_mirrors; |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
# Anti-hijacking measure: Only do this if our current |
142
|
|
|
|
|
|
|
# age is more than 30 days. We can almost certainly |
143
|
|
|
|
|
|
|
# handle a 1 month changeover period, otherwise things |
144
|
|
|
|
|
|
|
# will only be bad for a month. |
145
|
0
|
0
|
|
|
|
0
|
if ( $self->age < THIRTY_DAYS ) { |
146
|
0
|
|
|
|
|
0
|
return 1; |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
# Find all the servers updated in the last 2 days. |
150
|
|
|
|
|
|
|
# All of them except 1 must agree (prevent hijacking, |
151
|
|
|
|
|
|
|
# and handle accidents or anti-update attack from older server) |
152
|
0
|
|
|
|
|
0
|
my %uri = (); |
153
|
0
|
0
|
|
|
|
0
|
map { $uri{$_->uri}++ } grep { $_->age >= 0 and $_->age < TWO_DAYS } $self->mirrors; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
154
|
0
|
|
|
|
|
0
|
my @uris = sort { $uri{$b} <=> $uri{$a} } keys %uri; |
|
0
|
|
|
|
|
0
|
|
155
|
0
|
0
|
0
|
|
|
0
|
unless ( scalar(@uris) <= 2 and $uris[0] and $uris[0] >= (scalar($self->mirrors) - 1) ) { |
|
|
|
0
|
|
|
|
|
156
|
|
|
|
|
|
|
# Data is weird or currupt |
157
|
0
|
|
|
|
|
0
|
return 1; |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
# Master has moved. |
161
|
|
|
|
|
|
|
# Pull the new master server mirror.yaml |
162
|
0
|
0
|
|
|
|
0
|
my $new_uri = Mirror::YAML::URI->new( |
163
|
|
|
|
|
|
|
uri => URI->new( $uris[0] ), |
164
|
|
|
|
|
|
|
) or return 1; |
165
|
0
|
0
|
|
|
|
0
|
$new_uri->get or return 1; |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# To avoid pulling a whole bunch of mirror.yml files again |
168
|
|
|
|
|
|
|
# copy any mirrors from our set to the new |
169
|
0
|
0
|
|
|
|
0
|
my $new = $new_uri->yaml or return 1; |
170
|
0
|
|
|
|
|
0
|
my %old = map { $_->uri => $_ } $self->mirrors; |
|
0
|
|
|
|
|
0
|
|
171
|
0
|
|
|
|
|
0
|
foreach ( @{ $new->{mirrors} } ) { |
|
0
|
|
|
|
|
0
|
|
172
|
0
|
0
|
|
|
|
0
|
if ( $old{$_->uri} ) { |
173
|
0
|
|
|
|
|
0
|
$_ = $old{$_->uri}; |
174
|
|
|
|
|
|
|
} else { |
175
|
0
|
|
|
|
|
0
|
$_->get; |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
# Now overwrite ourself with the new one |
180
|
0
|
|
|
|
|
0
|
%$self = %$new; |
181
|
|
|
|
|
|
|
|
182
|
0
|
|
|
|
|
0
|
return 1; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
# Select the "best" mirrors |
186
|
|
|
|
|
|
|
sub select_mirrors { |
187
|
1
|
|
|
1
|
0
|
683
|
my $self = shift; |
188
|
1
|
|
50
|
|
|
45
|
my $wanted = _POSINT(shift) || 3; |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
# Check the mirrors |
191
|
1
|
|
|
|
|
16
|
$self->check_mirrors; |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
# Start with the list of all live mirrors, and create |
194
|
|
|
|
|
|
|
# some interesting subsets. |
195
|
0
|
|
|
|
|
0
|
my @live = sort { $a->lag <=> $b->lag } |
|
14
|
|
|
|
|
29
|
|
196
|
1
|
|
|
|
|
5
|
grep { $_->live } $self->mirrors; |
197
|
1
|
|
|
|
|
4
|
my @current = grep { $_->yaml->age < ONE_DAY } @live; |
|
0
|
|
|
|
|
0
|
|
198
|
1
|
|
|
|
|
2
|
my @ideal = grep { $_->lag < 2 } @current; |
|
0
|
|
|
|
|
0
|
|
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
# If there are enough fast and up-to-date mirrors |
201
|
|
|
|
|
|
|
# (which should be common for many people) return them. |
202
|
1
|
50
|
|
|
|
5
|
if ( @ideal >= $wanted ) { |
203
|
0
|
|
|
|
|
0
|
return map { $_->uri } @ideal[0 .. $wanted]; |
|
0
|
|
|
|
|
0
|
|
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
# If there are enough up-to-date mirrors |
207
|
|
|
|
|
|
|
# (which should be common) return them. |
208
|
1
|
50
|
|
|
|
4
|
if ( @current >= $wanted ) { |
209
|
0
|
|
|
|
|
0
|
return map { $_->uri } @current[0 .. $wanted]; |
|
0
|
|
|
|
|
0
|
|
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
# Are there ANY that are up to date |
213
|
1
|
50
|
|
|
|
4
|
if ( @current ) { |
214
|
0
|
|
|
|
|
0
|
return map { $_->uri } @current; |
|
0
|
|
|
|
|
0
|
|
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
# Something is weird, just use the master site |
218
|
1
|
|
|
|
|
7
|
return ( $self->uri ); |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
1; |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
__END__ |