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] )
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<_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.
77 Returns the path of the output file on success, false on failure.
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'] );
83 And the C<LWP> function will be skipped by C<File::Fetch>.
89 my $conf = $self->configure_object;
92 local $Params::Check::NO_DUPLICATES = 0;
94 my ($modobj, $verbose, $force, $fetch_from);
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'),
101 verbose => { default => $conf->get_conf('verbose'),
102 store => \$verbose },
103 prefer_bin => { default => $conf->get_conf('prefer_bin') },
107 my $args = check( $tmpl, \%hash ) or return;
109 ### check if we already downloaded the thing ###
110 if( (my $where = $modobj->status->fetch()) && !$force ) {
111 msg(loc("Already fetched '%1' to '%2', " .
112 "won't fetch again without force",
113 $modobj->module, $where ), $verbose );
117 my ($remote_file, $local_file, $local_path);
119 ### build the local path to downlaod to ###
121 $local_path = $args->{fetchdir} ||
123 $conf->get_conf('base'),
127 ### create the path if it doesn't exist ###
128 unless( -d $local_path ) {
129 unless( $self->_mkdir( dir => $local_path ) ) {
130 msg( loc("Could not create path '%1'", $local_path), $verbose);
135 $local_file = File::Spec->rel2abs(
143 ### do we already have the file? ###
144 if( -e $local_file ) {
146 if( $args->{force} ) {
148 ### some fetches will fail if the files exist already, so let's
149 ### delete them first
151 or msg( loc("Could not delete %1, some methods may " .
152 "fail to force a download", $local_file), $verbose);
155 ### store where we fetched it ###
156 $modobj->status->fetch( $local_file );
163 ### we got a custom URI
165 my $abs = $self->__file_fetch( from => $fetch_from,
167 verbose => $verbose );
170 error(loc("Unable to download '%1'", $fetch_from));
174 ### store where we fetched it ###
175 $modobj->status->fetch( $abs );
179 ### we will get it from one of our mirrors
181 ### build the remote path to download from ###
182 { $remote_file = File::Spec::Unix->catfile(
186 unless( $remote_file ) {
187 error( loc('No remote file given for download') );
192 ### see if we even have a host or a method to use to download with ###
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!
203 ### set up some flags for File::Fetch ###
204 local $File'Fetch::BLACKLIST = $conf->_get_fetch('blacklist');
205 local $File'Fetch::TIMEOUT = $conf->get_conf('timeout');
206 local $File'Fetch::DEBUG = $conf->get_conf('debug');
207 local $File'Fetch::FTP_PASSIVE = $conf->get_conf('passive');
208 local $File'Fetch::FROM_EMAIL = $conf->get_conf('email');
209 local $File'Fetch::PREFER_BIN = $conf->get_conf('prefer_bin');
210 local $File'Fetch::WARN = $verbose;
213 ### loop over all hosts we have ###
214 for my $host ( @{$conf->get_conf('hosts')} ) {
217 my $mirror_path = File::Spec::Unix->catfile(
218 $host->{'path'}, $remote_file
221 ### build pretty print uri ###
223 if( $host->{'scheme'} eq 'file' ) {
224 $where = CREATE_FILE_URI->(
225 File::Spec::Unix->rel2abs(
226 File::Spec::Unix->catdir(
227 grep { defined $_ && length $_ }
234 my %args = ( scheme => $host->{scheme},
235 host => $host->{host},
236 path => $mirror_path,
239 $where = $self->_host_to_uri( %args );
242 my $abs = $self->__file_fetch( from => $where,
244 verbose => $verbose );
246 ### we got a path back?
248 ### store where we fetched it ###
249 $modobj->status->fetch( $abs );
251 ### this host is good, the previous ones are apparently
252 ### not, so mark them as such.
253 $self->_add_fail_host( host => $_ ) for @maybe_bad_host;
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
262 push @maybe_bad_host, $host;
267 ? 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"));
278 my $conf = $self->configure_object;
281 my ($where, $local_path, $verbose);
283 from => { required => 1, store => \$where },
284 to => { required => 1, store => \$local_path },
285 verbose => { default => $conf->get_conf('verbose'),
286 store => \$verbose },
289 check( $tmpl, \%hash ) or return;
291 msg(loc("Trying to get '%1'", $where ), $verbose );
293 ### build the object ###
294 my $ff = File::Fetch->new( uri => $where );
297 error(loc("Bad uri '%1'",$where)), return unless $ff;
299 if( my $file = $ff->fetch( to => $local_path ) ) {
300 unless( -e $file && -s _ ) {
301 msg(loc("'%1' said it fetched '%2', but it was not created",
302 'File::Fetch', $file), $verbose);
305 my $abs = File::Spec->rel2abs( $file );
310 error(loc("Fetching of '%1' failed: %2", $where, $ff->error));
318 =head2 _add_fail_host( host => $host_hashref )
320 Mark a particular host as bad. This makes C<CPANPLUS::Internals::Fetch>
321 skip it in fetches until this cache is flushed.
323 =head2 _host_ok( host => $host_hashref )
325 Query the cache to see if this host is ok, or if it has been flagged
328 Returns true if the host is ok, false otherwise.
332 { ### caching functions ###
340 host => { required => 1, default => {},
341 strict_type => 1, store => \$host },
344 check( $tmpl, \%hash ) or return;
346 return $self->_hosts->{$host} = 1;
355 host => { required => 1, store => \$host },
358 check( $tmpl, \%hash ) or return;
360 return $self->_hosts->{$host} ? 0 : 1;
368 # c-indentation-style: bsd
370 # indent-tabs-mode: nil
372 # vim: expandtab shiftwidth=4: