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 $where;
 218
 219                 ### file:// uris are special and need parsing
 220                 if( $host->{'scheme'} eq 'file' ) {
 221
 222                     ### the full path in the native format of the OS
 223                     my $host_spec =
 224                             File::Spec->file_name_is_absolute( $host->{'path'} )
 225                                 ? $host->{'path'}
 226                                 : File::Spec->rel2abs( $host->{'path'} );
 227
 228                     ### there might be volumes involved on vms/win32
 229                     if( ON_WIN32 or ON_VMS ) {
 230
 231                         ### now extract the volume in order to be Win32 and
 232                         ### VMS friendly.
 233                         ### 'no_file' indicates that there's no file part
 234                         ### of this path, so we only get 2 bits returned.
 235                         my ($vol, $host_path) = File::Spec->splitpath(
 236                                                     $host_spec, 'no_file'
 237                                                 );
 238
 239                         ### and split up the directories
 240                         my @host_dirs = File::Spec->splitdir( $host_path );
 241
 242                         ### if we got a volume we pretend its a directory for
 243                         ### the sake of the file:// url
 244                         if( defined $vol and $vol ) {
 245
 246                             ### D:\foo\bar needs to be encoded as D|\foo\bar
 247                             ### For details, see the following link:
 248                             ###   http://en.wikipedia.org/wiki/File://
 249                             ### The RFC doesnt seem to address Windows volume
 250                             ### descriptors but it does address VMS volume
 251                             ### descriptors, however wikipedia covers a bit of
 252                             ### history regarding win32
 253                             $vol =~ s/:$/|/ if ON_WIN32;
 254
 255                             $vol =~ s/:// if ON_VMS;
 256
 257                             ### XXX i'm not sure what cases this is addressing.
 258                             ### this comes straight from dmq's file:// patches
 259                             ### for win32. --kane
 260                             if( $host_dirs[0] ) {
 261                                 unshift @host_dirs, $vol;
 262                             } else {
 263                                 $host_dirs[0] = $vol;
 264                             }
 265                         }
 266
 267                         ### now it's in UNIX format, which is the same format
 268                         ### as used for URIs
 269                         $host_spec = File::Spec::Unix->catdir( @host_dirs );
 270                     }
 271
 272                     ### now create the file:// uri from the components
 273                     $where = CREATE_FILE_URI->(
 274                                     File::Spec::Unix->catfile(
 275                                         $host->{'host'} || '',
 276                                         $host_spec,
 277                                         $remote_file,
 278                                     )
 279                                 );
 280
 281                 ### its components will be in unix format, for a http://,
 282                 ### ftp:// or any other style of URI
 283                 } else {
 284                     my $mirror_path = File::Spec::Unix->catfile(
 285                                             $host->{'path'}, $remote_file
 286                                         );
 287
 288                     my %args = ( scheme => $host->{scheme},
 289                                  host   => $host->{host},
 290                                  path   => $mirror_path,
 291                                 );
 292
 293                     $where = $self->_host_to_uri( %args );
 294                 }
 295
 296                 my $abs = $self->__file_fetch(  from    => $where,
 297                                                 to      => $local_path,
 298                                                 verbose => $verbose );
 299
 300                 ### we got a path back?
 301                 if( $abs ) {
 302                     ### store where we fetched it ###
 303                     $modobj->status->fetch( $abs );
 304
 305                     ### this host is good, the previous ones are apparently
 306                     ### not, so mark them as such.
 307                     $self->_add_fail_host( host => $_ ) for @maybe_bad_host;
 308
 309                     return $abs;
 310                 }
 311
 312                 ### so we tried to get the file but didn't actually fetch it --
 313                 ### there's a chance this host is bad. mark it as such and
 314                 ### actually flag it back if we manage to get the file
 315                 ### somewhere else
 316                 push @maybe_bad_host, $host;
 317             }
 318         }
 319
 320         $found_host
 321             ? error(loc("Fetch failed: host list exhausted " .
 322                         "-- are you connected today?"))
 323             : error(loc("No hosts found to download from " .
 324                         "-- check your config"));
 325     }
 326
 327     return;
 328 }
 329
 330 sub __file_fetch {
 331     my $self = shift;
 332     my $conf = $self->configure_object;
 333     my %hash = @_;
 334
 335     my ($where, $local_path, $verbose);
 336     my $tmpl = {
 337         from    => { required   => 1, store => \$where },
 338         to      => { required   => 1, store => \$local_path },
 339         verbose => { default    => $conf->get_conf('verbose'),
 340                      store      => \$verbose },
 341     };
 342
 343     check( $tmpl, \%hash ) or return;
 344
 345     msg(loc("Trying to get '%1'", $where ), $verbose );
 346
 347     ### build the object ###
 348     my $ff = File::Fetch->new( uri => $where );
 349
 350     ### sanity check ###
 351     error(loc("Bad uri '%1'",$where)), return unless $ff;
 352
 353     if( my $file = $ff->fetch( to => $local_path ) ) {
 354         unless( -e $file && -s _ ) {
 355             msg(loc("'%1' said it fetched '%2', but it was not created",
 356                     'File::Fetch', $file), $verbose);
 357
 358         } else {
 359             my $abs = File::Spec->rel2abs( $file );
 360             return $abs;
 361         }
 362
 363     } else {
 364         error(loc("Fetching of '%1' failed: %2", $where, $ff->error));
 365     }
 366
 367     return;
 368 }
 369
 370 =pod
 371
 372 =head2 _add_fail_host( host => $host_hashref )
 373
 374 Mark a particular host as bad. This makes C<CPANPLUS::Internals::Fetch>
 375 skip it in fetches until this cache is flushed.
 376
 377 =head2 _host_ok( host => $host_hashref )
 378
 379 Query the cache to see if this host is ok, or if it has been flagged
 380 as bad.
 381
 382 Returns true if the host is ok, false otherwise.
 383
 384 =cut
 385
 386 {   ### caching functions ###
 387
 388     sub _add_fail_host {
 389         my $self = shift;
 390         my %hash = @_;
 391
 392         my $host;
 393         my $tmpl = {
 394             host => { required      => 1, default   => {},
 395                       strict_type   => 1, store     => \$host },
 396         };
 397
 398         check( $tmpl, \%hash ) or return;
 399
 400         return $self->_hosts->{$host} = 1;
 401     }
 402
 403     sub _host_ok {
 404         my $self = shift;
 405         my %hash = @_;
 406
 407         my $host;
 408         my $tmpl = {
 409             host => { required => 1, store => \$host },
 410         };
 411
 412         check( $tmpl, \%hash ) or return;
 413
 414         return $self->_hosts->{$host} ? 0 : 1;
 415     }
 416 }
 417
 418
 419 1;
 420
 421 # Local variables:
 422 # c-indentation-style: bsd
 423 # c-basic-offset: 4
 424 # indent-tabs-mode: nil
 425 # End:
 426 # vim: expandtab shiftwidth=4: