File Coverage

lib/CPANPLUS/Internals/Fetch.pm
Criterion Covered Total %
statement 104 122 85.2
branch 24 42 57.1
condition 5 9 55.6
subroutine 14 14 100.0
pod n/a
total 147 187 78.6


line stmt bran cond sub pod time code
1             package CPANPLUS::Internals::Fetch;
2              
3 15     15   231 use strict;
  15         224  
  15         230  
4              
5 15     15   249 use CPANPLUS::Error;
  15         140  
  15         489  
6 15     15   244 use CPANPLUS::Internals::Constants;
  15         272  
  15         298  
7              
8 15     15   820 use File::Fetch;
  15         150  
  15         396  
9 15     15   304 use File::Spec;
  15         186  
  15         293  
10 15     15   249 use Cwd qw[cwd];
  15         140  
  15         763  
11 15     15   275 use IPC::Cmd qw[run];
  15         162  
  15         251  
12 15     15   240 use Params::Check qw[check];
  15         185  
  15         250  
13 15     15   235 use Module::Load::Conditional qw[can_load];
  15         140  
  15         351  
14 15     15   246 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  15         140  
  15         396  
15              
16             $Params::Check::VERBOSE = 1;
17              
18             =pod
19            
20             =head1 NAME
21            
22             CPANPLUS::Internals::Fetch
23            
24             =head1 SYNOPSIS
25            
26             my $output = $cb->_fetch(
27             module => $modobj,
28             fetchdir => '/path/to/save/to',
29             verbose => BOOL,
30             force => BOOL,
31             );
32            
33             $cb->_add_fail_host( host => 'foo.com' );
34             $cb->_host_ok( host => 'foo.com' );
35            
36            
37             =head1 DESCRIPTION
38            
39             CPANPLUS::Internals::Fetch fetches files from either ftp, http, file
40             or rsync mirrors.
41            
42             This is the rough flow:
43            
44             $cb->_fetch
45             Delegate to File::Fetch;
46            
47            
48             =head1 METHODS
49            
50             =cut
51              
52             =head1 $path = _fetch( module => $modobj, [fetchdir => '/path/to/save/to', fetch_from => 'scheme://path/to/fetch/from', verbose => BOOL, force => BOOL, prefer_bin => BOOL] )
53            
54             C<_fetch> will fetch files based on the information in a module
55             object. You always need a module object. If you want a fake module
56             object for a one-off fetch, look at C<CPANPLUS::Module::Fake>.
57            
58             C<fetchdir> is the place to save the file to. Usually this
59             information comes from your configuration, but you can override it
60             expressly if needed.
61            
62             C<fetch_from> lets you specify an URI to get this file from. If you
63             do not specify one, your list of configured hosts will be probed to
64             download the file from.
65            
66             C<force> forces a new download, even if the file already exists.
67            
68             C<verbose> simply indicates whether or not to print extra messages.
69            
70             C<prefer_bin> indicates whether you prefer the use of commandline
71             programs over perl modules. Defaults to your corresponding config
72             setting.
73            
74             C<_fetch> figures out, based on the host list, what scheme to use and
75             from there, delegates to C<File::Fetch> do the actual fetching.
76            
77             Returns the path of the output file on success, false on failure.
78            
79             Note that you can set a C<blacklist> on certain methods in the config.
80             Simply add the identifying name of the method (ie, C<lwp>) to:
81             $conf->_set_fetch( blacklist => ['lwp'] );
82            
83             And the C<LWP> function will be skipped by C<File::Fetch>.
84            
85             =cut
86              
87             sub _fetch {
88 60     60   908     my $self = shift;
89 60         924     my $conf = $self->configure_object;
90 60         1284     my %hash = @_;
91              
92 60         867     local $Params::Check::NO_DUPLICATES = 0;
93              
94 60         621     my ($modobj, $verbose, $force, $fetch_from);
95 60         3139     my $tmpl = {
96                     module => { required => 1, allow => IS_MODOBJ, store => \$modobj },
97                     fetchdir => { default => $conf->get_conf('fetchdir') },
98                     fetch_from => { default => '', store => \$fetch_from },
99                     force => { default => $conf->get_conf('force'),
100                                         store => \$force },
101                     verbose => { default => $conf->get_conf('verbose'),
102                                         store => \$verbose },
103                     prefer_bin => { default => $conf->get_conf('prefer_bin') },
104                 };
105              
106              
107 60 50       1664     my $args = check( $tmpl, \%hash ) or return;
108              
109             ### check if we already downloaded the thing ###
110 60 50 66     1164     if( (my $where = $modobj->status->fetch()) && !$force ) {
111 0         0         msg(loc("Already fetched '%1' to '%2', " .
112                             "won't fetch again without force",
113                             $modobj->module, $where ), $verbose );
114 0         0         return $where;
115                 }
116              
117 60         582     my ($remote_file, $local_file, $local_path);
118              
119             ### build the local path to downlaod to ###
120                 {
121 60   66     549         $local_path = $args->{fetchdir} ||
  60         4001  
122                                     File::Spec->catdir(
123                                         $conf->get_conf('base'),
124                                         $modobj->path,
125                                     );
126              
127             ### create the path if it doesn't exist ###
128 60 50       5792         unless( -d $local_path ) {
129 0 0       0             unless( $self->_mkdir( dir => $local_path ) ) {
130 0         0                 msg( loc("Could not create path '%1'", $local_path), $verbose);
131 0         0                 return;
132                         }
133                     }
134              
135 60         1434         $local_file = File::Spec->rel2abs(
136                                     File::Spec->catfile(
137                                                 $local_path,
138                                                 $modobj->package,
139                                     )
140                                 );
141                 }
142              
143             ### do we already have the file? ###
144 60 100       10154     if( -e $local_file ) {
145              
146 59 100       3261         if( $args->{force} ) {
147              
148             ### some fetches will fail if the files exist already, so let's
149             ### delete them first
150 43 50       13451             unlink $local_file
151                             or msg( loc("Could not delete %1, some methods may " .
152                                         "fail to force a download", $local_file), $verbose);
153                      } else {
154              
155             ### store where we fetched it ###
156 16         1928             $modobj->status->fetch( $local_file );
157              
158 16         31422             return $local_file;
159                     }
160                 }
161              
162              
163             ### we got a custom URI
164 44 50       1220     if ( $fetch_from ) {
165 0         0         my $abs = $self->__file_fetch( from => $fetch_from,
166                                                     to => $local_path,
167                                                     verbose => $verbose );
168                                                     
169 0 0       0         unless( $abs ) {
170 0         0             error(loc("Unable to download '%1'", $fetch_from));
171 0         0             return;
172                     }
173              
174             ### store where we fetched it ###
175 0         0         $modobj->status->fetch( $abs );
176              
177 0         0         return $abs;
178              
179             ### we will get it from one of our mirrors
180                 } else {
181             ### build the remote path to download from ###
182 44         986         { $remote_file = File::Spec::Unix->catfile(
  44         5139  
183                                                     $modobj->path,
184                                                     $modobj->package,
185                                                 );
186 44 50       947             unless( $remote_file ) {
187 0         0                 error( loc('No remote file given for download') );
188 0         0                 return;
189                         }
190                     }
191                 
192             ### see if we even have a host or a method to use to download with ###
193 44         585         my $found_host;
194 44         633         my @maybe_bad_host;
195                 
196 44         9755         HOST: {
197             ### F*CKING PIECE OF F*CKING p4 SHIT makes
198             ### '$File :: Fetch::SOME_VAR'
199             ### into a meta variable and starts substituting the file name...
200             ### GRAAAAAAAAAAAAAAAAAAAAAAH!
201             ### use ' to combat it!
202                 
203             ### set up some flags for File::Fetch ###
204 44         504             local $File'Fetch::BLACKLIST = $conf->_get_fetch('blacklist');
205 44         1188             local $File'Fetch::TIMEOUT = $conf->get_conf('timeout');
206 44         1302             local $File'Fetch::DEBUG = $conf->get_conf('debug');
207 44         936             local $File'Fetch::FTP_PASSIVE = $conf->get_conf('passive');
208 44         1033             local $File'Fetch::FROM_EMAIL = $conf->get_conf('email');
209 44         1438             local $File'Fetch::PREFER_BIN = $conf->get_conf('prefer_bin');
210 44         578             local $File'Fetch::WARN = $verbose;
211                 
212                 
213             ### loop over all hosts we have ###
214 44         690             for my $host ( @{$conf->get_conf('hosts')} ) {
  44         876  
215 45         604                 $found_host++;
216                 
217 45         930                 my $mirror_path = File::Spec::Unix->catfile(
218                                                     $host->{'path'}, $remote_file
219                                                 );
220                 
221             ### build pretty print uri ###
222 45         521                 my $where;
223 45 50       920                 if( $host->{'scheme'} eq 'file' ) {
224 90 100       4687                     $where = CREATE_FILE_URI->(
225                                             File::Spec::Unix->rel2abs(
226                                                 File::Spec::Unix->catdir(
227 45         868                                         grep { defined $_ && length $_ }
228                                                     $host->{'host'},
229                                                     $mirror_path
230                                                  )
231                                             )
232                                         );
233                             } else {
234 0         0                     my %args = ( scheme => $host->{scheme},
235                                              host => $host->{host},
236                                              path => $mirror_path,
237                                             );
238                                 
239 0         0                     $where = $self->_host_to_uri( %args );
240                             }
241                 
242 45         8975                 my $abs = $self->__file_fetch( from => $where,
243                                                             to => $local_path,
244                                                             verbose => $verbose );
245                             
246             ### we got a path back?
247 45 100       9971                 if( $abs ) {
248             ### store where we fetched it ###
249 44         7852                     $modobj->status->fetch( $abs );
250                     
251             ### this host is good, the previous ones are apparently
252             ### not, so mark them as such.
253 44         626                     $self->_add_fail_host( host => $_ ) for @maybe_bad_host;
  44         1658  
254                                     
255 44         33453                     return $abs;
256                             }
257                             
258             ### so we tried to get the file but didn't actually fetch it --
259             ### there's a chance this host is bad. mark it as such and
260             ### actually flag it back if we manage to get the file
261             ### somewhere else
262 1         29                 push @maybe_bad_host, $host;
263                         }
264                     }
265                 
266                     $found_host
267 0 0       0             ? error(loc("Fetch failed: host list exhausted " .
268                                     "-- are you connected today?"))
269                         : error(loc("No hosts found to download from " .
270                                     "-- check your config"));
271                 }
272                 
273 0         0     return;
274             }
275              
276             sub __file_fetch {
277 45     45   1827     my $self = shift;
278 45         6019     my $conf = $self->configure_object;
279 45         6199     my %hash = @_;
280              
281 45         640     my ($where, $local_path, $verbose);
282 45         13363     my $tmpl = {
283                     from => { required => 1, store => \$where },
284                     to => { required => 1, store => \$local_path },
285                     verbose => { default => $conf->get_conf('verbose'),
286                                  store => \$verbose },
287                 };
288                 
289 45 50       7881     check( $tmpl, \%hash ) or return;
290              
291 45         4617     msg(loc("Trying to get '%1'", $where ), $verbose );
292              
293             ### build the object ###
294 45         6666     my $ff = File::Fetch->new( uri => $where );
295              
296             ### sanity check ###
297 45 50       9076     error(loc("Bad uri '%1'",$where)), return unless $ff;
298              
299 45 100       832     if( my $file = $ff->fetch( to => $local_path ) ) {
300 44 50 33     40727         unless( -e $file && -s _ ) {
301 0         0             msg(loc("'%1' said it fetched '%2', but it was not created",
302                                 'File::Fetch', $file), $verbose);
303              
304                     } else {
305 44         3414             my $abs = File::Spec->rel2abs( $file );
306 44         26963             return $abs;
307                     }
308              
309                 } else {
310 1         67         error(loc("Fetching of '%1' failed: %2", $where, $ff->error));
311                 }
312              
313 1         165     return;
314             }
315              
316             =pod
317            
318             =head2 _add_fail_host( host => $host_hashref )
319            
320             Mark a particular host as bad. This makes C<CPANPLUS::Internals::Fetch>
321             skip it in fetches until this cache is flushed.
322            
323