summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm473
1 files changed, 473 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm
new file mode 100644
index 00000000000..395965bab60
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm
@@ -0,0 +1,473 @@
+package CPANPLUS::Internals::Fetch;
+
+use strict;
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+
+use File::Fetch;
+use File::Spec;
+use Cwd qw[cwd];
+use IPC::Cmd qw[run];
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+$Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Internals::Fetch
+
+=head1 SYNOPSIS
+
+ my $output = $cb->_fetch(
+ module => $modobj,
+ fetchdir => '/path/to/save/to',
+ verbose => BOOL,
+ force => BOOL,
+ );
+
+ $cb->_add_fail_host( host => 'foo.com' );
+ $cb->_host_ok( host => 'foo.com' );
+
+
+=head1 DESCRIPTION
+
+CPANPLUS::Internals::Fetch fetches files from either ftp, http, file
+or rsync mirrors.
+
+This is the rough flow:
+
+ $cb->_fetch
+ Delegate to File::Fetch;
+
+
+=head1 METHODS
+
+=cut
+
+=head1 $path = _fetch( module => $modobj, [fetchdir => '/path/to/save/to', fetch_from => 'scheme://path/to/fetch/from', verbose => BOOL, force => BOOL, prefer_bin => BOOL, ttl => $seconds] )
+
+C<_fetch> will fetch files based on the information in a module
+object. You always need a module object. If you want a fake module
+object for a one-off fetch, look at C<CPANPLUS::Module::Fake>.
+
+C<fetchdir> is the place to save the file to. Usually this
+information comes from your configuration, but you can override it
+expressly if needed.
+
+C<fetch_from> lets you specify an URI to get this file from. If you
+do not specify one, your list of configured hosts will be probed to
+download the file from.
+
+C<force> forces a new download, even if the file already exists.
+
+C<verbose> simply indicates whether or not to print extra messages.
+
+C<prefer_bin> indicates whether you prefer the use of commandline
+programs over perl modules. Defaults to your corresponding config
+setting.
+
+C<ttl> (in seconds) indicates how long a cached copy is valid for. If
+the fetch time of the local copy is within the ttl, the cached copy is
+returned. Otherwise, the file is refetched.
+
+C<_fetch> figures out, based on the host list, what scheme to use and
+from there, delegates to C<File::Fetch> do the actual fetching.
+
+Returns the path of the output file on success, false on failure.
+
+Note that you can set a C<blacklist> on certain methods in the config.
+Simply add the identifying name of the method (ie, C<lwp>) to:
+ $conf->_set_fetch( blacklist => ['lwp'] );
+
+And the C<LWP> function will be skipped by C<File::Fetch>.
+
+=cut
+
+sub _fetch {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ local $Params::Check::NO_DUPLICATES = 0;
+
+ my ($modobj, $verbose, $force, $fetch_from, $ttl);
+ my $tmpl = {
+ module => { required => 1, allow => IS_MODOBJ, store => \$modobj },
+ fetchdir => { default => $conf->get_conf('fetchdir') },
+ fetch_from => { default => '', store => \$fetch_from },
+ force => { default => $conf->get_conf('force'),
+ store => \$force },
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ prefer_bin => { default => $conf->get_conf('prefer_bin') },
+ ttl => { default => 0, store => \$ttl },
+ };
+
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ ### check if we already downloaded the thing ###
+ if( (my $where = $modobj->status->fetch()) and not $force and not $ttl ) {
+
+ msg(loc("Already fetched '%1' to '%2', " .
+ "won't fetch again without force",
+ $modobj->module, $where ), $verbose );
+ return $where;
+ }
+
+ my ($remote_file, $local_file, $local_path);
+
+ ### build the local path to downlaod to ###
+ {
+ $local_path = $args->{fetchdir} ||
+ File::Spec->catdir(
+ $conf->get_conf('base'),
+ $modobj->path,
+ );
+
+ ### create the path if it doesn't exist ###
+ unless( -d $local_path ) {
+ unless( $self->_mkdir( dir => $local_path ) ) {
+ msg( loc("Could not create path '%1'", $local_path), $verbose);
+ return;
+ }
+ }
+
+ $local_file = File::Spec->rel2abs(
+ File::Spec->catfile(
+ $local_path,
+ $modobj->package,
+ )
+ );
+
+ ### do we already have the file? if so, can we use the cached version,
+ ### or do we need to refetch?
+ if( -e $local_file ) {
+
+ my $unlink = 0;
+ my $use_cached = 0;
+
+ ### if force is in effect, we have to refetch
+ if( $force ) {
+ $unlink++
+
+ ### if you provided a ttl, and it was exceeded, we'll refetch,
+ } elsif( $ttl and ([stat $local_file]->[9] + $ttl > time) ) {
+ msg(loc("Using cached file '%1' on disk; ".
+ "ttl (%2s) is not exceeded",
+ $local_file, $ttl), $verbose );
+
+ $use_cached++;
+
+ ### if you provided a ttl, and the above conditional didn't match,
+ ### we exceeded the ttl, so we refetch
+ } elsif ( $ttl ) {
+ $unlink++;
+
+ ### otherwise we can use the cached version
+ } else {
+ $use_cached++;
+ }
+
+ if( $unlink ) {
+ ### some fetches will fail if the files exist already, so let's
+ ### delete them first
+ 1 while unlink $local_file;
+
+ msg(loc("Could not delete %1, some methods may " .
+ "fail to force a download", $local_file), $verbose)
+ if -e $local_file;
+
+ } else {
+
+ ### store where we fetched it ###
+ $modobj->status->fetch( $local_file );
+
+ return $local_file;
+ }
+ }
+ }
+
+
+ ### we got a custom URI
+ if ( $fetch_from ) {
+ my $abs = $self->__file_fetch( from => $fetch_from,
+ to => $local_path,
+ verbose => $verbose );
+
+ unless( $abs ) {
+ error(loc("Unable to download '%1'", $fetch_from));
+ return;
+ }
+
+ ### store where we fetched it ###
+ $modobj->status->fetch( $abs );
+
+ return $abs;
+
+ ### we will get it from one of our mirrors
+ } else {
+ ### build the remote path to download from ###
+ { $remote_file = File::Spec::Unix->catfile(
+ $modobj->path,
+ $modobj->package,
+ );
+ unless( $remote_file ) {
+ error( loc('No remote file given for download') );
+ return;
+ }
+ }
+
+ ### see if we even have a host or a method to use to download with ###
+ my $found_host;
+ my @maybe_bad_host;
+
+ HOST: {
+ ### F*CKING PIECE OF F*CKING p4 SHIT makes
+ ### '$File :: Fetch::SOME_VAR'
+ ### into a meta variable and starts substituting the file name...
+ ### GRAAAAAAAAAAAAAAAAAAAAAAH!
+ ### use ' to combat it!
+
+ ### set up some flags for File::Fetch ###
+ local $File'Fetch::BLACKLIST = $conf->_get_fetch('blacklist');
+ local $File'Fetch::TIMEOUT = $conf->get_conf('timeout');
+ local $File'Fetch::DEBUG = $conf->get_conf('debug');
+ local $File'Fetch::FTP_PASSIVE = $conf->get_conf('passive');
+ local $File'Fetch::FROM_EMAIL = $conf->get_conf('email');
+ local $File'Fetch::PREFER_BIN = $conf->get_conf('prefer_bin');
+ local $File'Fetch::WARN = $verbose;
+
+
+ ### loop over all hosts we have ###
+ for my $host ( @{$conf->get_conf('hosts')} ) {
+ $found_host++;
+
+ my $where;
+
+ ### file:// uris are special and need parsing
+ if( $host->{'scheme'} eq 'file' ) {
+
+ ### the full path in the native format of the OS
+ my $host_spec =
+ File::Spec->file_name_is_absolute( $host->{'path'} )
+ ? $host->{'path'}
+ : File::Spec->rel2abs( $host->{'path'} );
+
+ ### there might be volumes involved on vms/win32
+ if( ON_WIN32 or ON_VMS ) {
+
+ ### now extract the volume in order to be Win32 and
+ ### VMS friendly.
+ ### 'no_file' indicates that there's no file part
+ ### of this path, so we only get 2 bits returned.
+ my ($vol, $host_path) = File::Spec->splitpath(
+ $host_spec, 'no_file'
+ );
+
+ ### and split up the directories
+ my @host_dirs = File::Spec->splitdir( $host_path );
+
+ ### if we got a volume we pretend its a directory for
+ ### the sake of the file:// url
+ if( defined $vol and $vol ) {
+
+ ### D:\foo\bar needs to be encoded as D|\foo\bar
+ ### For details, see the following link:
+ ### http://en.wikipedia.org/wiki/File://
+ ### The RFC doesnt seem to address Windows volume
+ ### descriptors but it does address VMS volume
+ ### descriptors, however wikipedia covers a bit of
+ ### history regarding win32
+ $vol =~ s/:$/|/ if ON_WIN32;
+
+ $vol =~ s/:// if ON_VMS;
+
+ ### XXX i'm not sure what cases this is addressing.
+ ### this comes straight from dmq's file:// patches
+ ### for win32. --kane
+ ### According to dmq, the best summary is:
+ ### "if file:// urls dont look right on VMS reuse
+ ### the win32 logic and see if that fixes things"
+
+ ### first element not empty? Might happen on VMS.
+ ### prepend the volume in that case.
+ if( $host_dirs[0] ) {
+ unshift @host_dirs, $vol;
+
+ ### element empty? reuse it to store the volume
+ ### encoded as a directory name. (Win32/VMS)
+ } else {
+ $host_dirs[0] = $vol;
+ }
+ }
+
+ ### now it's in UNIX format, which is the same format
+ ### as used for URIs
+ $host_spec = File::Spec::Unix->catdir( @host_dirs );
+ }
+
+ ### now create the file:// uri from the components
+ $where = CREATE_FILE_URI->(
+ File::Spec::Unix->catfile(
+ $host->{'host'} || '',
+ $host_spec,
+ $remote_file,
+ )
+ );
+
+ ### its components will be in unix format, for a http://,
+ ### ftp:// or any other style of URI
+ } else {
+ my $mirror_path = File::Spec::Unix->catfile(
+ $host->{'path'}, $remote_file
+ );
+
+ my %args = ( scheme => $host->{scheme},
+ host => $host->{host},
+ path => $mirror_path,
+ );
+
+ $where = $self->_host_to_uri( %args );
+ }
+
+ my $abs = $self->__file_fetch( from => $where,
+ to => $local_path,
+ verbose => $verbose );
+
+ ### we got a path back?
+ if( $abs ) {
+ ### store where we fetched it ###
+ $modobj->status->fetch( $abs );
+
+ ### this host is good, the previous ones are apparently
+ ### not, so mark them as such.
+ $self->_add_fail_host( host => $_ ) for @maybe_bad_host;
+
+ return $abs;
+ }
+
+ ### so we tried to get the file but didn't actually fetch it --
+ ### there's a chance this host is bad. mark it as such and
+ ### actually flag it back if we manage to get the file
+ ### somewhere else
+ push @maybe_bad_host, $host;
+ }
+ }
+
+ $found_host
+ ? error(loc("Fetch failed: host list exhausted " .
+ "-- are you connected today?"))
+ : error(loc("No hosts found to download from " .
+ "-- check your config"));
+ }
+
+ return;
+}
+
+sub __file_fetch {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my ($where, $local_path, $verbose);
+ my $tmpl = {
+ from => { required => 1, store => \$where },
+ to => { required => 1, store => \$local_path },
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ msg(loc("Trying to get '%1'", $where ), $verbose );
+
+ ### build the object ###
+ my $ff = File::Fetch->new( uri => $where );
+
+ ### sanity check ###
+ error(loc("Bad uri '%1'",$where)), return unless $ff;
+
+ if( my $file = $ff->fetch( to => $local_path ) ) {
+ unless( -e $file && -s _ ) {
+ msg(loc("'%1' said it fetched '%2', but it was not created",
+ 'File::Fetch', $file), $verbose);
+
+ } else {
+ my $abs = File::Spec->rel2abs( $file );
+
+ ### so TTLs will work
+ $self->_update_timestamp( file => $abs );
+
+ return $abs;
+ }
+
+ } else {
+ error(loc("Fetching of '%1' failed: %2", $where, $ff->error));
+ }
+
+ return;
+}
+
+=pod
+
+=head2 _add_fail_host( host => $host_hashref )
+
+Mark a particular host as bad. This makes C<CPANPLUS::Internals::Fetch>
+skip it in fetches until this cache is flushed.
+
+=head2 _host_ok( host => $host_hashref )
+
+Query the cache to see if this host is ok, or if it has been flagged
+as bad.
+
+Returns true if the host is ok, false otherwise.
+
+=cut
+
+{ ### caching functions ###
+
+ sub _add_fail_host {
+ my $self = shift;
+ my %hash = @_;
+
+ my $host;
+ my $tmpl = {
+ host => { required => 1, default => {},
+ strict_type => 1, store => \$host },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ return $self->_hosts->{$host} = 1;
+ }
+
+ sub _host_ok {
+ my $self = shift;
+ my %hash = @_;
+
+ my $host;
+ my $tmpl = {
+ host => { required => 1, store => \$host },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ return $self->_hosts->{$host} ? 0 : 1;
+ }
+}
+
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4: