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                             ### According to dmq, the best summary is:
 261                             ### "if file:// urls dont look right on VMS reuse
 262                             ### the win32 logic and see if that fixes things"
 263
 264                             ### first element not empty? Might happen on VMS.
 265                             ### prepend the volume in that case.
 266                             if( $host_dirs[0] ) {
 267                                 unshift @host_dirs, $vol;
 268
 269                             ### element empty? reuse it to store the volume
 270                             ### encoded as a directory name. (Win32/VMS)
 271                             } else {
 272                                 $host_dirs[0] = $vol;
 273                             }
 274                         }
 275
 276                         ### now it's in UNIX format, which is the same format
 277                         ### as used for URIs
 278                         $host_spec = File::Spec::Unix->catdir( @host_dirs );
 279                     }
 280
 281                     ### now create the file:// uri from the components
 282                     $where = CREATE_FILE_URI->(
 283                                     File::Spec::Unix->catfile(
 284                                         $host->{'host'} || '',
 285                                         $host_spec,
 286                                         $remote_file,
 287                                     )
 288                                 );
 289
 290                 ### its components will be in unix format, for a http://,
 291                 ### ftp:// or any other style of URI
 292                 } else {
 293                     my $mirror_path = File::Spec::Unix->catfile(
 294                                             $host->{'path'}, $remote_file
 295                                         );
 296
 297                     my %args = ( scheme => $host->{scheme},
 298                                  host   => $host->{host},
 299                                  path   => $mirror_path,
 300                                 );
 301
 302                     $where = $self->_host_to_uri( %args );
 303                 }
 304
 305                 my $abs = $self->__file_fetch(  from    => $where,
 306                                                 to      => $local_path,
 307                                                 verbose => $verbose );
 308
 309                 ### we got a path back?
 310                 if( $abs ) {
 311                     ### store where we fetched it ###
 312                     $modobj->status->fetch( $abs );
 313
 314                     ### this host is good, the previous ones are apparently
 315                     ### not, so mark them as such.
 316                     $self->_add_fail_host( host => $_ ) for @maybe_bad_host;
 317
 318                     return $abs;
 319                 }
 320
 321                 ### so we tried to get the file but didn't actually fetch it --
 322                 ### there's a chance this host is bad. mark it as such and
 323                 ### actually flag it back if we manage to get the file
 324                 ### somewhere else
 325                 push @maybe_bad_host, $host;
 326             }
 327         }
 328
 329         $found_host
 330             ? error(loc("Fetch failed: host list exhausted " .
 331                         "-- are you connected today?"))
 332             : error(loc("No hosts found to download from " .
 333                         "-- check your config"));
 334     }
 335
 336     return;
 337 }
 338
 339 sub __file_fetch {
 340     my $self = shift;
 341     my $conf = $self->configure_object;
 342     my %hash = @_;
 343
 344     my ($where, $local_path, $verbose);
 345     my $tmpl = {
 346         from    => { required   => 1, store => \$where },
 347         to      => { required   => 1, store => \$local_path },
 348         verbose => { default    => $conf->get_conf('verbose'),
 349                      store      => \$verbose },
 350     };
 351
 352     check( $tmpl, \%hash ) or return;
 353
 354     msg(loc("Trying to get '%1'", $where ), $verbose );
 355
 356     ### build the object ###
 357     my $ff = File::Fetch->new( uri => $where );
 358
 359     ### sanity check ###
 360     error(loc("Bad uri '%1'",$where)), return unless $ff;
 361
 362     if( my $file = $ff->fetch( to => $local_path ) ) {
 363         unless( -e $file && -s _ ) {
 364             msg(loc("'%1' said it fetched '%2', but it was not created",
 365                     'File::Fetch', $file), $verbose);
 366
 367         } else {
 368             my $abs = File::Spec->rel2abs( $file );
 369             return $abs;
 370         }
 371
 372     } else {
 373         error(loc("Fetching of '%1' failed: %2", $where, $ff->error));
 374     }
 375
 376     return;
 377 }
 378
 379 =pod
 380
 381 =head2 _add_fail_host( host => $host_hashref )
 382
 383 Mark a particular host as bad. This makes C<CPANPLUS::Internals::Fetch>
 384 skip it in fetches until this cache is flushed.
 385
 386 =head2 _host_ok( host => $host_hashref )
 387
 388 Query the cache to see if this host is ok, or if it has been flagged
 389 as bad.
 390
 391 Returns true if the host is ok, false otherwise.
 392
 393 =cut
 394
 395 {   ### caching functions ###
 396
 397     sub _add_fail_host {
 398         my $self = shift;
 399         my %hash = @_;
 400
 401         my $host;
 402         my $tmpl = {
 403             host => { required      => 1, default   => {},
 404                       strict_type   => 1, store     => \$host },
 405         };
 406
 407         check( $tmpl, \%hash ) or return;
 408
 409         return $self->_hosts->{$host} = 1;
 410     }
 411
 412     sub _host_ok {
 413         my $self = shift;
 414         my %hash = @_;
 415
 416         my $host;
 417         my $tmpl = {
 418             host => { required => 1, store => \$host },
 419         };
 420
 421         check( $tmpl, \%hash ) or return;
 422
 423         return $self->_hosts->{$host} ? 0 : 1;
 424     }
 425 }
 426
 427
 428 1;
 429
 430 # Local variables:
 431 # c-indentation-style: bsd
 432 # c-basic-offset: 4
 433 # indent-tabs-mode: nil
 434 # End:
 435 # vim: expandtab shiftwidth=4: