lib/CPANPLUS/Internals/Fetch.pm

   1 package CPANPLUS::Internals::Fetch;
   2
   3 use strict;
   4
   5 use CPANPLUS::Error;
   6 use CPANPLUS::Internals::Constants;
   7
   8 use File::Fetch;
   9 use File::Spec;
  10 use Cwd                         qw[cwd];
  11 use IPC::Cmd                    qw[run];
  12 use Params::Check               qw[check];
  13 use Module::Load::Conditional   qw[can_load];
  14 use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
  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     my $self = shift;
  89     my $conf = $self->configure_object;
  90     my %hash = @_;
  91
  92     local $Params::Check::NO_DUPLICATES = 0;
  93
  94     my ($modobj, $verbose, $force, $fetch_from);
  95     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     my $args = check( $tmpl, \%hash ) or return;
 108
 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 );
 114         return $where;
 115     }
 116
 117     my ($remote_file, $local_file, $local_path);
 118
 119     ### build the local path to downlaod to ###
 120     {
 121         $local_path =   $args->{fetchdir} ||
 122                         File::Spec->catdir(
 123                             $conf->get_conf('base'),
 124                             $modobj->path,
 125                         );
 126
 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);
 131                 return;
 132             }
 133         }
 134
 135         $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     if( -e $local_file ) {
 145
 146         if( $args->{force} ) {
 147
 148             ### some fetches will fail if the files exist already, so let's
 149             ### delete them first
 150             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             $modobj->status->fetch( $local_file );
 157
 158             return $local_file;
 159         }
 160     }
 161
 162
 163     ### we got a custom URI
 164     if ( $fetch_from ) {
 165         my $abs = $self->__file_fetch(  from    => $fetch_from,
 166                                         to      => $local_path,
 167                                         verbose => $verbose );
 168
 169         unless( $abs ) {
 170             error(loc("Unable to download '%1'", $fetch_from));
 171             return;
 172         }
 173
 174         ### store where we fetched it ###
 175         $modobj->status->fetch( $abs );
 176
 177         return $abs;
 178
 179     ### we will get it from one of our mirrors
 180     } else {
 181         ### build the remote path to download from ###
 182         {   $remote_file = File::Spec::Unix->catfile(
 183                                         $modobj->path,
 184                                         $modobj->package,
 185                                     );
 186             unless( $remote_file ) {
 187                 error( loc('No remote file given for download') );
 188                 return;
 189             }
 190         }
 191
 192         ### see if we even have a host or a method to use to download with ###
 193         my $found_host;
 194         my @maybe_bad_host;
 195
 196         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             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;
 211
 212
 213             ### loop over all hosts we have ###
 214             for my $host ( @{$conf->get_conf('hosts')} ) {
 215                 $found_host++;
 216
 217                 my $mirror_path = File::Spec::Unix->catfile(
 218                                         $host->{'path'}, $remote_file
 219                                     );
 220
 221                 ### build pretty print uri ###
 222                 my $where;
 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 $_ }
 228                                         $host->{'host'},
 229                                         $mirror_path
 230                                      )
 231                                 )
 232                             );
 233                 } else {
 234                     my %args = ( scheme => $host->{scheme},
 235                                  host   => $host->{host},
 236                                  path   => $mirror_path,
 237                                 );
 238
 239                     $where = $self->_host_to_uri( %args );
 240                 }
 241
 242                 my $abs = $self->__file_fetch(  from    => $where,
 243                                                 to      => $local_path,
 244                                                 verbose => $verbose );
 245
 246                 ### we got a path back?
 247                 if( $abs ) {
 248                     ### store where we fetched it ###
 249                     $modobj->status->fetch( $abs );
 250
 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;
 254
 255                     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                 push @maybe_bad_host, $host;
 263             }
 264         }
 265
 266         $found_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"));
 271     }
 272
 273     return;
 274 }
 275
 276 sub __file_fetch {
 277     my $self = shift;
 278     my $conf = $self->configure_object;
 279     my %hash = @_;
 280
 281     my ($where, $local_path, $verbose);
 282     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     check( $tmpl, \%hash ) or return;
 290
 291     msg(loc("Trying to get '%1'", $where ), $verbose );
 292
 293     ### build the object ###
 294     my $ff = File::Fetch->new( uri => $where );
 295
 296     ### sanity check ###
 297     error(loc("Bad uri '%1'",$where)), return unless $ff;
 298
 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);
 303
 304         } else {
 305             my $abs = File::Spec->rel2abs( $file );
 306             return $abs;
 307         }
 308
 309     } else {
 310         error(loc("Fetching of '%1' failed: %2", $where, $ff->error));
 311     }
 312
 313     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 =head2 _host_ok( host => $host_hashref )
 324
 325 Query the cache to see if this host is ok, or if it has been flagged
 326 as bad.
 327
 328 Returns true if the host is ok, false otherwise.
 329
 330 =cut
 331
 332 {   ### caching functions ###
 333
 334     sub _add_fail_host {
 335         my $self = shift;
 336         my %hash = @_;
 337
 338         my $host;
 339         my $tmpl = {
 340             host => { required      => 1, default   => {},
 341                       strict_type   => 1, store     => \$host },
 342         };
 343
 344         check( $tmpl, \%hash ) or return;
 345
 346         return $self->_hosts->{$host} = 1;
 347     }
 348
 349     sub _host_ok {
 350         my $self = shift;
 351         my %hash = @_;
 352
 353         my $host;
 354         my $tmpl = {
 355             host => { required => 1, store => \$host },
 356         };
 357
 358         check( $tmpl, \%hash ) or return;
 359
 360         return $self->_hosts->{$host} ? 0 : 1;
 361     }
 362 }
 363
 364
 365 1;
 366
 367 # Local variables:
 368 # c-indentation-style: bsd
 369 # c-basic-offset: 4
 370 # indent-tabs-mode: nil
 371 # End:
 372 # vim: expandtab shiftwidth=4: