view release on metacpan or  search on metacpan

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

    for my $method ( @{ $METHODS->{$self->scheme} } ) {
        my $sub =  '_'.$method.'_fetch';
        
        unless( __PACKAGE__->can($sub) ) {
            warn "Can not call method for '$method' -- WEIRD!\n";
            next;
        }

        ### method is blacklisted ###
        next if grep { lc $_ eq $method } @$BLACKLIST;

        ### method is known to fail ###
        next if $METHOD_FAIL->{$method};
             
        if(my $file = $self->$sub(to=>File::Spec->catfile($to,$self->file))){
            
            unless( -e $file && -s _ ) {
                warn "'$method' said it fetched '$file', ".
                     "but it was not created\n";

                ### mark the failure ###
                $METHOD_FAIL->{$method} = 1;
            
                next;
            
            } else {
            
                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;
}        

#line 256

########################
### _*_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( can_load(modules => $use_list) ) {
      
        ### 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 );                        
        $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file';

        ### set up the useragent object 
        my $ua = LWP::UserAgent->new();
        $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 {
            warn "Fetch failed! HTTP response code: '". $res->code ."' [".
            HTTP::Status::status_message($res->code). "]\n";     
            return;            
        }
    
    } else {       
        $METHOD_FAIL->{'lwp'} = 1;
        return;
    }
}          

### Net::FTP fetching    
sub _netftp_fetch {
    my $self = shift;
    my %hash = @_;
    
    my ($to);
    my $tmpl = {
        to  => { required => 1, store => \$to }
    };     
    check( $tmpl, \%hash ) or return;
    
    ### required modules ###
    my $use_list = { 'Net::FTP' => 0 };
                
    if( can_load( modules => $use_list ) ) {

        ### make connection ###    
        my $ftp;
        unless( $ftp = Net::FTP->new( $self->host ) ) {