<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">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 =&gt; 'CPANPLUS', Style =&gt; 'gettext';

$Params::Check::VERBOSE = 1;

=pod

=head1 NAME

CPANPLUS::Internals::Fetch - internals for fetching files

=head1 SYNOPSIS

    my $output = $cb-&gt;_fetch(
                        module      =&gt; $modobj,
                        fetchdir    =&gt; '/path/to/save/to',
                        verbose     =&gt; BOOL,
                        force       =&gt; BOOL,
                    );

    $cb-&gt;_add_fail_host( host =&gt; 'foo.com' );
    $cb-&gt;_host_ok(       host =&gt; 'foo.com' );


=head1 DESCRIPTION

CPANPLUS::Internals::Fetch fetches files from either ftp, http, file
or rsync mirrors.

This is the rough flow:

    $cb-&gt;_fetch
        Delegate to File::Fetch;


=head1 METHODS

=cut

=head1 $path = _fetch( module =&gt; $modobj, [fetchdir =&gt; '/path/to/save/to', fetch_from =&gt; 'scheme://path/to/fetch/from', verbose =&gt; BOOL, force =&gt; BOOL, prefer_bin =&gt; BOOL, ttl =&gt; $seconds] )

C&lt;_fetch&gt; 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&lt;CPANPLUS::Module::Fake&gt;.

C&lt;fetchdir&gt; is the place to save the file to. Usually this
information comes from your configuration, but you can override it
expressly if needed.

C&lt;fetch_from&gt; 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&lt;force&gt; forces a new download, even if the file already exists.

C&lt;verbose&gt; simply indicates whether or not to print extra messages.

C&lt;prefer_bin&gt; indicates whether you prefer the use of commandline
programs over perl modules. Defaults to your corresponding config
setting.

C&lt;ttl&gt; (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&lt;_fetch&gt; figures out, based on the host list, what scheme to use and
from there, delegates to C&lt;File::Fetch&gt; do the actual fetching.

Returns the path of the output file on success, false on failure.

Note that you can set a C&lt;blacklist&gt; on certain methods in the config.
Simply add the identifying name of the method (ie, C&lt;lwp&gt;) to:
    $conf-&gt;_set_fetch( blacklist =&gt; ['lwp'] );

And the C&lt;LWP&gt; function will be skipped by C&lt;File::Fetch&gt;.

=cut

sub _fetch {
    my $self = shift;
    my $conf = $self-&gt;configure_object;
    my %hash = @_;

    local $Params::Check::NO_DUPLICATES = 0;

    my ($modobj, $verbose, $force, $fetch_from, $ttl);
    my $tmpl = {
        module      =&gt; { required =&gt; 1, allow =&gt; IS_MODOBJ, store =&gt; \$modobj },
        fetchdir    =&gt; { default =&gt; $conf-&gt;get_conf('fetchdir') },
        fetch_from  =&gt; { default =&gt; '', store =&gt; \$fetch_from },
        force       =&gt; { default =&gt; $conf-&gt;get_conf('force'),
                            store =&gt; \$force },
        verbose     =&gt; { default =&gt; $conf-&gt;get_conf('verbose'),
                            store =&gt; \$verbose },
        prefer_bin  =&gt; { default =&gt; $conf-&gt;get_conf('prefer_bin') },
        ttl         =&gt; { default =&gt; 0, store =&gt; \$ttl },
    };


    my $args = check( $tmpl, \%hash ) or return;

    ### check if we already downloaded the thing ###
    if( (my $where = $modobj-&gt;status-&gt;fetch()) and not $force and not $ttl ) {

        msg(loc("Already fetched '%1' to '%2', " .
                "won't fetch again without force",
                $modobj-&gt;module, $where ), $verbose );
        return $where;
    }

    my ($remote_file, $local_file, $local_path);

    ### build the local path to download to ###
    {
        $local_path =   $args-&gt;{fetchdir} ||
                        File::Spec-&gt;catdir(
                            $conf-&gt;get_conf('base'),
                            $modobj-&gt;path,
                        );

        ### create the path if it doesn't exist ###
        unless( -d $local_path ) {
            unless( $self-&gt;_mkdir( dir =&gt; $local_path ) ) {
                msg( loc("Could not create path '%1'", $local_path), $verbose);
                return;
            }
        }

        $local_file = File::Spec-&gt;rel2abs(
                        File::Spec-&gt;catfile(
                                    $local_path,
                                    $modobj-&gt;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]-&gt;[9] + $ttl &gt; 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-&gt;status-&gt;fetch( $local_file );

                return $local_file;
            }
        }
    }


    ### we got a custom URI
    if ( $fetch_from ) {
        my $abs = $self-&gt;__file_fetch(  from    =&gt; $fetch_from,
                                        to      =&gt; $local_path,
                                        verbose =&gt; $verbose );

        unless( $abs ) {
            error(loc("Unable to download '%1'", $fetch_from));
            return;
        }

        ### store where we fetched it ###
        $modobj-&gt;status-&gt;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-&gt;catfile(
                                        $modobj-&gt;path,
                                        $modobj-&gt;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-&gt;_get_fetch('blacklist');
            local $File'Fetch::TIMEOUT      = $conf-&gt;get_conf('timeout');
            local $File'Fetch::DEBUG        = $conf-&gt;get_conf('debug');
            local $File'Fetch::FTP_PASSIVE  = $conf-&gt;get_conf('passive');
            local $File'Fetch::FROM_EMAIL   = $conf-&gt;get_conf('email');
            local $File'Fetch::PREFER_BIN   = $conf-&gt;get_conf('prefer_bin');
            local $File'Fetch::WARN         = $verbose;


            ### loop over all hosts we have ###
            for my $host ( @{$conf-&gt;get_conf('hosts')} ) {
                $found_host++;

                my $where;

                ### file:// uris are special and need parsing
                if( $host-&gt;{'scheme'} eq 'file' ) {

                    ### the full path in the native format of the OS
                    my $host_spec =
                            File::Spec-&gt;file_name_is_absolute( $host-&gt;{'path'} )
                                ? $host-&gt;{'path'}
                                : File::Spec-&gt;rel2abs( $host-&gt;{'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-&gt;splitpath(
                                                    $host_spec, 'no_file'
                                                );

                        ### and split up the directories
                        my @host_dirs = File::Spec-&gt;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 doesn't 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-&gt;catdir( @host_dirs );
                    }

                    ### now create the file:// uri from the components
                    $where = CREATE_FILE_URI-&gt;(
                                    File::Spec::Unix-&gt;catfile(
                                        $host-&gt;{'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-&gt;catfile(
                                            $host-&gt;{'path'}, $remote_file
                                        );

                    my %args = ( scheme =&gt; $host-&gt;{scheme},
                                 host   =&gt; $host-&gt;{host},
                                 path   =&gt; $mirror_path,
                                );

                    $where = $self-&gt;_host_to_uri( %args );
                }

                my $abs = $self-&gt;__file_fetch(  from    =&gt; $where,
                                                to      =&gt; $local_path,
                                                verbose =&gt; $verbose );

                ### we got a path back?
                if( $abs ) {
                    ### store where we fetched it ###
                    $modobj-&gt;status-&gt;fetch( $abs );

                    ### this host is good, the previous ones are apparently
                    ### not, so mark them as such.
                    $self-&gt;_add_fail_host( host =&gt; $_ ) 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-&gt;configure_object;
    my %hash = @_;

    my ($where, $local_path, $verbose);
    my $tmpl = {
        from    =&gt; { required   =&gt; 1, store =&gt; \$where },
        to      =&gt; { required   =&gt; 1, store =&gt; \$local_path },
        verbose =&gt; { default    =&gt; $conf-&gt;get_conf('verbose'),
                     store      =&gt; \$verbose },
    };

    check( $tmpl, \%hash ) or return;

    msg(loc("Trying to get '%1'", $where ), $verbose );

    ### build the object ###
    my $ff = File::Fetch-&gt;new( uri =&gt; $where );

    ### sanity check ###
    error(loc("Bad uri '%1'",$where)), return unless $ff;

    if( my $file = $ff-&gt;fetch( to =&gt; $local_path ) ) {
        unless( -e $file &amp;&amp; -s _ ) {
            msg(loc("'%1' said it fetched '%2', but it was not created",
                    'File::Fetch', $file), $verbose);

        } else {
            my $abs = File::Spec-&gt;rel2abs( $file );

            ### so TTLs will work
            $self-&gt;_update_timestamp( file =&gt; $abs );

            return $abs;
        }

    } else {
        error(loc("Fetching of '%1' failed: %2", $where, $ff-&gt;error));
    }

    return;
}

=pod

=head2 _add_fail_host( host =&gt; $host_hashref )

Mark a particular host as bad. This makes C&lt;CPANPLUS::Internals::Fetch&gt;
skip it in fetches until this cache is flushed.

=head2 _host_ok( host =&gt; $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 =&gt; { required      =&gt; 1, default   =&gt; {},
                      strict_type   =&gt; 1, store     =&gt; \$host },
        };

        check( $tmpl, \%hash ) or return;

        return $self-&gt;_hosts-&gt;{$host} = 1;
    }

    sub _host_ok {
        my $self = shift;
        my %hash = @_;

        my $host;
        my $tmpl = {
            host =&gt; { required =&gt; 1, store =&gt; \$host },
        };

        check( $tmpl, \%hash ) or return;

        return $self-&gt;_hosts-&gt;{$host} ? 0 : 1;
    }
}


1;

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
</pre></body></html>