[Summary view] [Print] [Text view]

   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: