view release on metacpan or  search on metacpan

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

  $fname = $self->_hack_fname($fname);

  #########
  # Add in useful segment information for empty segments
  # In theory there should only ever be one element in @{$self->{'seginfo'}}
  # as requests are parallelised by segment
  #
  for my $req (keys %{$results}) {
    if(!$results->{$req} ||
       scalar @{$results->{$req}} == 0) {
      $results->{$req} = $self->{'currentsegs'}->{$req};
    }
  }

  #########
  # fix ups
  #
  if($fname eq 'entry_points') {
    $DEBUG and print {*STDERR} qq(Running postprocessing for entry_points\n);

    for my $s (keys %{$results}) {
      my $res = $results->{$s} || [];
      for my $r (@{$res}) {
	delete $r->{'segment_id'};
      }
    }

  } elsif($fname eq 'sequence') {
    $DEBUG and print {*STDERR} qq(Running postprocessing for dna\n);

    for my $s (keys %{$results}) {
      my $res = $results->{$s} || [];

      for my $r (@{$res}) {
	if(exists $r->{'dna'}) {
	  $r->{'dna'} =~ s/\s+//smgx;

	} elsif(exists $r->{'sequence'}) {
	  $r->{'sequence'} =~ s/\s+//smgx;
	}
      }
    }
  }
  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,
                };
  }