view release on metacpan or  search on metacpan

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

        my $normal = 0;
        while ( $select->can_read( $TIMEOUT || 60 ) ) {
          my $ret = $sock->sysread( $resp, 4096, length($resp) );
          if ( !defined $ret or $ret == 0 ) {
            $select->remove( $sock );
            $normal++;
          }
        }
        close $sock;

        unless ( $normal ) {
            return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 )));
        }

        # Check the "response"
        # Strip preceding blank lines apparently they are allowed (RFC 2616 4.1)
        $resp =~ s/^(\x0d?\x0a)+//;
        # Check it is an HTTP response
        unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) {
            return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host));
        }

        # Check for OK
        my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i;
        unless ( $code eq '200' ) {
            return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host));
        }

        {
          local $\;
          print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0];
        }
        close $fh;
        return $to;

    } else {
        $METHOD_FAIL->{'iosock'} = 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;
        my @options = ($self->host);
        push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
        unless( $ftp = Net::FTP->new( @options ) ) {
            return $self->_error(loc("Ftp creation failed: %1",$@));
        }

        ### login ###
        unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
            return $self->_error(loc("Could not login to '%1'",$self->host));
        }

        ### set binary mode, just in case ###
        $ftp->binary;

        ### create the remote path
        ### remember remote paths are unix paths! [#11483]
        my $remote = File::Spec::Unix->catfile( $self->path, $self->file );

        ### fetch the file ###
        my $target;
        unless( $target = $ftp->get( $remote, $to ) ) {
            return $self->_error(loc("Could not fetch '%1' from '%2'",
                        $remote, $self->host));
        }

        ### log out ###
        $ftp->quit;

        return $target;

    } else {
        $METHOD_FAIL->{'netftp'} = 1;
        return;
    }
}

### /bin/wget fetch ###
sub _wget_fetch {
    my $self = shift;
    my %hash = @_;

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

    ### see if we have a wget binary ###
    if( my $wget = can_run('wget') ) {

        ### no verboseness, thanks ###
        my $cmd = [ $wget, '--quiet' ];

        ### if a timeout is set, add it ###
        push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;

        ### run passive if specified ###
        push @$cmd, '--passive-ftp' if $FTP_PASSIVE;

        ### set the output document, add the uri ###
        push @$cmd, '--output-document', $to, $self->uri;