1 package CPANPLUS::Internals::Fetch;
6 use CPANPLUS::Internals::Constants;
12 use Params::Check qw[check];
13 use Module::Load::Conditional qw[can_load];
14 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
16 $Params::Check::VERBOSE = 1;
22 CPANPLUS::Internals::Fetch
26 my $output = $cb->_fetch(
28 fetchdir => '/path/to/save/to',
33 $cb->_add_fail_host( host => 'foo.com' );
34 $cb->_host_ok( host => 'foo.com' );
39 CPANPLUS::Internals::Fetch fetches files from either ftp, http, file
42 This is the rough flow:
45 Delegate to File::Fetch;
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, ttl => $seconds] )
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>.
58 C<fetchdir> is the place to save the file to. Usually this
59 information comes from your configuration, but you can override it
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.
66 C<force> forces a new download, even if the file already exists.
68 C<verbose> simply indicates whether or not to print extra messages.
70 C<prefer_bin> indicates whether you prefer the use of commandline
71 programs over perl modules. Defaults to your corresponding config
74 C<ttl> (in seconds) indicates how long a cached copy is valid for. If
75 the fetch time of the local copy is within the ttl, the cached copy is
76 returned. Otherwise, the file is refetched.
78 C<_fetch> figures out, based on the host list, what scheme to use and
79 from there, delegates to C<File::Fetch> do the actual fetching.
81 Returns the path of the output file on success, false on failure.
83 Note that you can set a C<blacklist> on certain methods in the config.
84 Simply add the identifying name of the method (ie, C<lwp>) to:
85 $conf->_set_fetch( blacklist => ['lwp'] );
87 And the C<LWP> function will be skipped by C<File::Fetch>.
93 my $conf = $self->configure_object;
96 local $Params::Check::NO_DUPLICATES = 0;
98 my ($modobj, $verbose, $force, $fetch_from, $ttl);
100 module => { required => 1, allow => IS_MODOBJ, store => \$modobj },
101 fetchdir => { default => $conf->get_conf('fetchdir') },
102 fetch_from => { default => '', store => \$fetch_from },
103 force => { default => $conf->get_conf('force'),
105 verbose => { default => $conf->get_conf('verbose'),
106 store => \$verbose },
107 prefer_bin => { default => $conf->get_conf('prefer_bin') },
108 ttl => { default => 0, store => \$ttl },
112 my $args = check( $tmpl, \%hash ) or return;
114 ### check if we already downloaded the thing ###
115 if( (my $where = $modobj->status->fetch()) and not $force and not $ttl ) {
117 msg(loc("Already fetched '%1' to '%2', " .
118 "won't fetch again without force",
119 $modobj->module, $where ), $verbose );
123 my ($remote_file, $local_file, $local_path);
125 ### build the local path to downlaod to ###
127 $local_path = $args->{fetchdir} ||
129 $conf->get_conf('base'),
133 ### create the path if it doesn't exist ###
134 unless( -d $local_path ) {
135 unless( $self->_mkdir( dir => $local_path ) ) {
136 msg( loc("Could not create path '%1'", $local_path), $verbose);
141 $local_file = File::Spec->rel2abs(
148 ### do we already have the file? if so, can we use the cached version,
149 ### or do we need to refetch?
150 if( -e $local_file ) {
155 ### if force is in effect, we have to refetch
159 ### if you provided a ttl, and it was exceeded, we'll refetch,
160 } elsif( $ttl and ([stat $local_file]->[9] + $ttl > time) ) {
161 msg(loc("Using cached file '%1' on disk; ".
162 "ttl (%2s) is not exceeded",
163 $local_file, $ttl), $verbose );
167 ### if you provided a ttl, and the above conditional didn't match,
168 ### we exceeded the ttl, so we refetch
172 ### otherwise we can use the cached version
178 ### some fetches will fail if the files exist already, so let's
179 ### delete them first
180 1 while unlink $local_file;
182 msg(loc("Could not delete %1, some methods may " .
183 "fail to force a download", $local_file), $verbose)
188 ### store where we fetched it ###
189 $modobj->status->fetch( $local_file );
197 ### we got a custom URI
199 my $abs = $self->__file_fetch( from => $fetch_from,
201 verbose => $verbose );
204 error(loc("Unable to download '%1'", $fetch_from));
208 ### store where we fetched it ###
209 $modobj->status->fetch( $abs );
213 ### we will get it from one of our mirrors
215 ### build the remote path to download from ###
216 { $remote_file = File::Spec::Unix->catfile(
220 unless( $remote_file ) {
221 error( loc('No remote file given for download') );
226 ### see if we even have a host or a method to use to download with ###
231 ### F*CKING PIECE OF F*CKING p4 SHIT makes
232 ### '$File :: Fetch::SOME_VAR'
233 ### into a meta variable and starts substituting the file name...
234 ### GRAAAAAAAAAAAAAAAAAAAAAAH!
235 ### use ' to combat it!
237 ### set up some flags for File::Fetch ###
238 local $File'Fetch::BLACKLIST = $conf->_get_fetch('blacklist');
239 local $File'Fetch::TIMEOUT = $conf->get_conf('timeout');
240 local $File'Fetch::DEBUG = $conf->get_conf('debug');
241 local $File'Fetch::FTP_PASSIVE = $conf->get_conf('passive');
242 local $File'Fetch::FROM_EMAIL = $conf->get_conf('email');
243 local $File'Fetch::PREFER_BIN = $conf->get_conf('prefer_bin');
244 local $File'Fetch::WARN = $verbose;
247 ### loop over all hosts we have ###
248 for my $host ( @{$conf->get_conf('hosts')} ) {
253 ### file:// uris are special and need parsing
254 if( $host->{'scheme'} eq 'file' ) {
256 ### the full path in the native format of the OS
258 File::Spec->file_name_is_absolute( $host->{'path'} )
260 : File::Spec->rel2abs( $host->{'path'} );
262 ### there might be volumes involved on vms/win32
263 if( ON_WIN32 or ON_VMS ) {
265 ### now extract the volume in order to be Win32 and
267 ### 'no_file' indicates that there's no file part
268 ### of this path, so we only get 2 bits returned.
269 my ($vol, $host_path) = File::Spec->splitpath(
270 $host_spec, 'no_file'
273 ### and split up the directories
274 my @host_dirs = File::Spec->splitdir( $host_path );
276 ### if we got a volume we pretend its a directory for
277 ### the sake of the file:// url
278 if( defined $vol and $vol ) {
280 ### D:\foo\bar needs to be encoded as D|\foo\bar
281 ### For details, see the following link:
282 ### http://en.wikipedia.org/wiki/File://
283 ### The RFC doesnt seem to address Windows volume
284 ### descriptors but it does address VMS volume
285 ### descriptors, however wikipedia covers a bit of
286 ### history regarding win32
287 $vol =~ s/:$/|/ if ON_WIN32;
289 $vol =~ s/:// if ON_VMS;
291 ### XXX i'm not sure what cases this is addressing.
292 ### this comes straight from dmq's file:// patches
293 ### for win32. --kane
294 ### According to dmq, the best summary is:
295 ### "if file:// urls dont look right on VMS reuse
296 ### the win32 logic and see if that fixes things"
298 ### first element not empty? Might happen on VMS.
299 ### prepend the volume in that case.
300 if( $host_dirs[0] ) {
301 unshift @host_dirs, $vol;
303 ### element empty? reuse it to store the volume
304 ### encoded as a directory name. (Win32/VMS)
306 $host_dirs[0] = $vol;
310 ### now it's in UNIX format, which is the same format
312 $host_spec = File::Spec::Unix->catdir( @host_dirs );
315 ### now create the file:// uri from the components
316 $where = CREATE_FILE_URI->(
317 File::Spec::Unix->catfile(
318 $host->{'host'} || '',
324 ### its components will be in unix format, for a http://,
325 ### ftp:// or any other style of URI
327 my $mirror_path = File::Spec::Unix->catfile(
328 $host->{'path'}, $remote_file
331 my %args = ( scheme => $host->{scheme},
332 host => $host->{host},
333 path => $mirror_path,
336 $where = $self->_host_to_uri( %args );
339 my $abs = $self->__file_fetch( from => $where,
341 verbose => $verbose );
343 ### we got a path back?
345 ### store where we fetched it ###
346 $modobj->status->fetch( $abs );
348 ### this host is good, the previous ones are apparently
349 ### not, so mark them as such.
350 $self->_add_fail_host( host => $_ ) for @maybe_bad_host;
355 ### so we tried to get the file but didn't actually fetch it --
356 ### there's a chance this host is bad. mark it as such and
357 ### actually flag it back if we manage to get the file
359 push @maybe_bad_host, $host;
364 ? error(loc("Fetch failed: host list exhausted " .
365 "-- are you connected today?"))
366 : error(loc("No hosts found to download from " .
367 "-- check your config"));
375 my $conf = $self->configure_object;
378 my ($where, $local_path, $verbose);
380 from => { required => 1, store => \$where },
381 to => { required => 1, store => \$local_path },
382 verbose => { default => $conf->get_conf('verbose'),
383 store => \$verbose },
386 check( $tmpl, \%hash ) or return;
388 msg(loc("Trying to get '%1'", $where ), $verbose );
390 ### build the object ###
391 my $ff = File::Fetch->new( uri => $where );
394 error(loc("Bad uri '%1'",$where)), return unless $ff;
396 if( my $file = $ff->fetch( to => $local_path ) ) {
397 unless( -e $file && -s _ ) {
398 msg(loc("'%1' said it fetched '%2', but it was not created",
399 'File::Fetch', $file), $verbose);
402 my $abs = File::Spec->rel2abs( $file );
404 ### so TTLs will work
405 $self->_update_timestamp( file => $abs );
411 error(loc("Fetching of '%1' failed: %2", $where, $ff->error));
419 =head2 _add_fail_host( host => $host_hashref )
421 Mark a particular host as bad. This makes C<CPANPLUS::Internals::Fetch>
422 skip it in fetches until this cache is flushed.
424 =head2 _host_ok( host => $host_hashref )
426 Query the cache to see if this host is ok, or if it has been flagged
429 Returns true if the host is ok, false otherwise.
433 { ### caching functions ###
441 host => { required => 1, default => {},
442 strict_type => 1, store => \$host },
445 check( $tmpl, \%hash ) or return;
447 return $self->_hosts->{$host} = 1;
456 host => { required => 1, store => \$host },
459 check( $tmpl, \%hash ) or return;
461 return $self->_hosts->{$host} ? 0 : 1;
469 # c-indentation-style: bsd
471 # indent-tabs-mode: nil
473 # vim: expandtab shiftwidth=4: