File Coverage

blib/lib/Mirror/YAML.pm
Criterion Covered Total %
statement 80 129 62.0
branch 12 38 31.5
condition 2 11 18.1
subroutine 23 29 79.3
pod 0 15 0.0
total 117 222 52.7


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__