view release on metacpan or  search on metacpan

lib/Bio/Das/Lite.pm  view on Meta::CPAN

  }
  return;
}

#########
# Set up the parallel HTTP fetching
# This uses our LWP::Parallel::UserAgent subclass which handles DAS statuses
#
sub _fetch {
  my ($self, $url_ref, $headers) = @_;

  $self->{'statuscodes'}  = {};
  $self->{'specversions'} = {};
  if(!$headers) {
    $headers = {};
  }

  if($ENV{HTTP_X_FORWARDED_FOR}) {
    $headers->{'X-Forwarded-For'} ||= $ENV{'HTTP_X_FORWARDED_FOR'};
  }
  $headers->{'X-DAS-Version'} ||= '1.6';

  # Convert header pairs to strings
  my @headers;
  for my $h (keys %{ $headers }) {
    push @headers, "$h: " . $headers->{$h};
  }

  # We will now issue the actual requests. Due to insufficient support for error
  # handling and proxies, we can't use WWW::Curl::Simple. So we generate a
  # WWW::Curl::Easy object here, and register it with WWW::Curl::Multi.

  my $curlm = WWW::Curl::Multi->new();
  my %reqs;
  my $i = 0;

  # First initiate the requests
  for my $url (keys %{$url_ref}) {
    if(ref $url_ref->{$url} ne 'CODE') {
      next;
    }
    $DEBUG and print {*STDERR} qq(Building WWW::Curl::Easy for $url [timeout=$self->{'timeout'}] via $url_ref->{$url}\n);

    $i++;
    my $curl = WWW::Curl::Easy->new();

    $curl->setopt( CURLOPT_NOPROGRESS, 1 );
    $curl->setopt( CURLOPT_FOLLOWLOCATION, 1 );
    $curl->setopt( CURLOPT_USERAGENT, $self->user_agent );
    $curl->setopt( CURLOPT_URL, $url );

    if (scalar @headers) {
        $curl->setopt( CURLOPT_HTTPHEADER, \@headers );
    }

    my ($body_ref, $head_ref);
    open my $fileb, q[>], \$body_ref or croak 'Error opening data handle'; ## no critic (RequireBriefOpen)
    $curl->setopt( CURLOPT_WRITEDATA, $fileb );

    open my $fileh, q[>], \$head_ref or croak 'Error opening header handle'; ## no critic (RequireBriefOpen)
    $curl->setopt( CURLOPT_WRITEHEADER, $fileh );

    # we set this so we have the ref later on
    $curl->setopt( CURLOPT_PRIVATE, $i );
    $curl->setopt( CURLOPT_TIMEOUT, $self->timeout || $TIMEOUT );
    #$curl->setopt( CURLOPT_CONNECTTIMEOUT, $self->connection_timeout || 2 );

    $self->_fetch_proxy_setup($curl);

    $curlm->add_handle($curl);

    $reqs{$i} = {
                 'uri'  => $url,
                 'easy' => $curl,
                 'head' => \$head_ref,
                 'body' => \$body_ref,
                };
  }

  $DEBUG and print {*STDERR} qq(Requests submitted. Waiting for content\n);

  $self->_receive($url_ref, $curlm, \%reqs);

  return;
}

sub _fetch_proxy_setup {
  my ($self, $curl) = @_;

  if ( my $proxy = $self->http_proxy ) {
    if ( defined $Bio::Das::Lite::{CURLOPT_PROXY} ) {
      $curl->setopt( &CURLOPT_PROXY, $proxy ); ## no critic (ProhibitAmpersandSigils)
    } else {
      croak 'Trying to set a proxy, but your version of libcurl does not support this feature';
    }
  }

  if ( my $proxy_user = $self->proxy_user ) {
    if ( defined $Bio::Das::Lite::{CURLOPT_PROXYUSERNAME} ) {
      $curl->setopt( &CURLOPT_PROXYUSERNAME, $proxy_user ); ## no critic (ProhibitAmpersandSigils)
    } else {
      croak 'Trying to set a proxy username, but your version of libcurl does not support this feature';
    }
  }

  if ( my $proxy_pass = $self->proxy_pass ) {
    if ( defined $Bio::Das::Lite::{CURLOPT_PROXYPASSWORD} ) {
      $curl->setopt( &CURLOPT_PROXYPASSWORD, $proxy_pass ); ## no critic (ProhibitAmpersandSigils)
    } else {
      croak 'Trying to set a proxy password, but your version of libcurl does not support this feature';
    }
  }

  my @no_proxy = @{ $self->no_proxy };
  if ( scalar @no_proxy ) {
    if ( defined $Bio::Das::Lite::{CURLOPT_NOPROXY} ) {
      $curl->setopt( &CURLOPT_NOPROXY, join q(,), @no_proxy ); ## no critic (ProhibitAmpersandSigils)
    } else {
      croak 'Trying to set proxy exclusions, but your version of libcurl does not support this feature';
    }
  }