view release on metacpan or  search on metacpan

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

          elsif ( $rc == 200 ) {
              return $to;
          }
          else {
            return $self->_error(loc("Fetch failed! HTTP response: %1 [%2]",
                        $rc, $http->status_message));
          }

        } # Loop for 5 retries.

        return $self->_error("Fetch failed! Gave up after 5 tries");

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

### Simple IO::Socket::INET fetching ###
sub _iosock_fetch {
    my $self = shift;
    my %hash = @_;

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

    my $use_list = {
        'IO::Socket::INET' => '0.0',
        'IO::Select'       => '0.0',
    };

    if( can_load(modules => $use_list) ) {
        my $sock = IO::Socket::INET->new(
            PeerHost => $self->host,
            ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ),
        );

        unless ( $sock ) {
            return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!));
        }

        my $fh = FileHandle->new;

        # Check open()

        unless ( $fh->open($to,'>') ) {
            return $self->_error(loc(
                 "Could not open '%1' for writing: %2",$to,$!));
        }

        $fh->autoflush(1);
        binmode $fh;

        my $path = File::Spec::Unix->catfile( $self->path, $self->file );
        my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a";
        $sock->send( $req );

        my $select = IO::Select->new( $sock );

        my $resp = '';
        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",$@));
        }