view release on metacpan or  search on metacpan

inc/bundle/File/Fetch.pm  view on Meta::CPAN

        )){

            unless( -e $file && -s _ ) {
                $self->_error(loc("'%1' said it fetched '%2', ".
                     "but it was not created",$method,$file));

                ### mark the failure ###
                $METHOD_FAIL->{$method} = 1;

                next;

            } else {

                ### slurp mode?
                if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {

                    ### open the file
                    open my $fh, "<$file" or do {
                        $self->_error(
                            loc("Could not open '%1': %2", $file, $!));
                        return;
                    };

                    ### slurp
                    $$target = do { local $/; <$fh> };

                }

                my $abs = File::Spec->rel2abs( $file );
                return $abs;

            }
        }
    }


    ### if we got here, we looped over all methods, but we weren't able
    ### to fetch it.
    return;
}

########################
### _*_fetch methods ###
########################

### LWP fetching ###
sub _lwp_fetch {
    my $self = shift;
    my %hash = @_;

    my ($to);
    my $tmpl = {
        to  => { required => 1, store => \$to }
    };
    check( $tmpl, \%hash ) or return;

    ### modules required to download with lwp ###
    my $use_list = {
        LWP                 => '0.0',
        'LWP::UserAgent'    => '0.0',
        'HTTP::Request'     => '0.0',
        'HTTP::Status'      => '0.0',
        URI                 => '0.0',

    };

    if ($self->scheme eq 'https') {
        $use_list->{'LWP::Protocol::https'} = '0';
    }

    ### Fix CVE-2016-1238 ###
    local $Module::Load::Conditional::FORCE_SAFE_INC = 1;
    unless( can_load( modules => $use_list ) ) {
        $METHOD_FAIL->{'lwp'} = 1;
        return;
    }

    ### setup the uri object
    my $uri = URI->new( File::Spec::Unix->catfile(
                                $self->path, $self->file
                    ) );

    ### special rules apply for file:// uris ###
    $uri->scheme( $self->scheme );
    $uri->host( $self->scheme eq 'file' ? '' : $self->host );

    if ($self->userinfo) {
        $uri->userinfo($self->userinfo);
    } elsif ($self->scheme ne 'file') {
        $uri->userinfo("anonymous:$FROM_EMAIL");
    }

    ### set up the useragent object
    my $ua = LWP::UserAgent->new();
    $ua->timeout( $TIMEOUT ) if $TIMEOUT;
    $ua->agent( $USER_AGENT );
    $ua->from( $FROM_EMAIL );
    $ua->env_proxy;

    my $res = $ua->mirror($uri, $to) or return;

    ### uptodate or fetched ok ###
    if ( $res->code == 304 or $res->code == 200 ) {
        return $to;

    } else {
        return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]",
                    $res->code, HTTP::Status::status_message($res->code),
                    $res->status_line));
    }

}

### HTTP::Tiny fetching ###
sub _httptiny_fetch {
    my $self = shift;
    my %hash = @_;

    my ($to);
    my $tmpl = {
        to  => { required => 1, store => \$to }