view release on metacpan or  search on metacpan

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

        my $uri = $self->uri;

        my $http = HTTP::Tiny->new( ( $TIMEOUT ? ( timeout => $TIMEOUT ) : () ) );

        my $rc = $http->mirror( $uri, $to );

        unless ( $rc->{success} ) {

            return $self->_error(loc( "Fetch failed! HTTP response: %1 [%2]",
                        $rc->{status}, $rc->{reason} ) );

        }

        return $to;

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

### HTTP::Lite fetching ###
sub _httplite_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 = {
        'HTTP::Lite'    => '2.2',

    };

    if( can_load(modules => $use_list) ) {

        my $uri = $self->uri;
        my $retries = 0;

        RETRIES: while ( $retries++ < 5 ) {

          my $http = HTTP::Lite->new();
          # Naughty naughty but there isn't any accessor/setter
          $http->{timeout} = $TIMEOUT if $TIMEOUT;
          $http->http11_mode(1);

          my $fh = FileHandle->new;

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

          $fh->autoflush(1);

          binmode $fh;

          my $rc = $http->request( $uri, sub { my ($self,$dref,$cbargs) = @_; local $\; print {$cbargs} $$dref }, $fh );

          close $fh;

          if ( $rc == 301 || $rc == 302 ) {
              my $loc;
              HEADERS: for ($http->headers_array) {
                /Location: (\S+)/ and $loc = $1, last HEADERS;
              }
              #$loc or last; # Think we should squeal here.
              if ($loc =~ m!^/!) {
                $uri =~ s{^(\w+?://[^/]+)/.*$}{$1};
                $uri .= $loc;
              }
              else {
                $uri = $loc;
              }
              next RETRIES;
          }
          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;