view release on metacpan or  search on metacpan

Das.pm  view on Meta::CPAN

    foreach (@$writable) {                      # handle is ready for writing
      my $fetcher = $self->{sockets}{$_};       # recover the HTTP fetcher
      my $result = $fetcher->send_request();               # try to send the request
      if ($result) {
	if ($result eq 'reading header') {    # request is sent, so monitor for reading
	  $readers->add($_);
	  $writers->remove($_);               # and remove from list monitored for writing
	}
      } else {  # some sort of error
	$fetcher->request->error($fetcher->error());       # copy the error message
	$writers->remove($_);                              # and remove from list monitored for writing
      }
    }

    foreach (@$readable) {                      # handle is ready for reading
      my $fetcher = $self->{sockets}{$_};       # recover the HTTP object
      my $result = $fetcher->read;              # read some data
      if($fetcher->error
	     && $fetcher->error =~ /^401\s/
	     && $self->auth_callback()) {       # Don't give up if given authentication challenge
	# The result will automatically appear, as fetcher contains request reference
	my $new_sock = $self->authenticate($fetcher);
	if ($new_sock) {
	  $writers->remove($_);
	  $readers->remove($_);
	  $writers->add($new_sock);
	}
      }
      unless ($result) {                        # remove if some error occurred
	$fetcher->request->error($fetcher->error) unless defined $result;
	$readers->remove($_);
	delete $self->{sockets}{$_};
      }
    }
  }

  # handle timeouts
  if ($timed_out) {
    while (my ($sock,$f) = each %{$self->{sockets}}) { # list of still-pending requests
      $f->request->error('509 timeout');
      $readers->remove($sock);
      $writers->remove($sock);
      close $sock;
    }
  }

  delete $self->{sockets};
  if ($self->oldstyle_api()) {
    unless ($requests->[0]->is_success) {
      $self->error($requests->[0]->error);
      return;
    }
    return wantarray ? $requests->[0]->results : ($requests->[0]->results)[0];
  }
  return wantarray ? @$requests : $requests->[0];
}

# The callback routine used below for authentication must accept three arguments: 
#    the fetcher object, the realm for authentication, and the iteration
# we are on.  A return of undef means that we should stop trying this connection (e.g. cancel button
# pressed, or x number of iterations tried), otherwise a two element array (not a reference to an array)
# should be returned with the username and password in that order.
# I assume if you've called autheniticate, it's because you've gotten a 401 error. 
# Otherwise this does not make sense.
# There is also no caching of authentication done.  I suggest the callback do this, so
# the user isn't asked 20 times for the same name and password.

sub authenticate($$$){
  my ($self, $fetcher) = @_;
  my $callback = $self->auth_callback;

  return undef unless defined $callback;

  $self->{auth_iter} = {} if not defined $self->{auth_iter};

  my ($realm) = $fetcher->error =~ /^\S+\s+'(.*)'/; 

  return if $self->{auth_iter}->{$realm} < 0;  # Sign that we've given up, don't try again

  my ($user, $pass) = &$callback ($fetcher, $realm, ++($self->{auth_iter}->{$realm}));

  if(!defined $user or $user eq ''){  #Give up, denote with negative iteration value
    $self->{auth_iter}->{$realm} = -1;
    return;
  }

  # Reuse request, adding the authentication info
  my $request = $fetcher->request;
  $self->remove_pending($fetcher);

  # How do we clean up the old fetcher,which is no longer needed?
  $request->auth($user,$pass);
  my $new_fetcher =  $self->make_fetcher($request) or return;
  $self->add_pending($new_fetcher);
  return $new_fetcher->socket;
}

1;

__END__


=head1 NAME

Bio::Das - Interface to Distributed Annotation System

=head1 SYNOPSIS

  use Bio::Das;

   # SERIAL API
   my $das = Bio::Das->new(-source => 'http://www.wormbase.org/db/das',
                           -dsn    => 'elegans',
                           -aggregators => ['primary_transcript','clone']);
   my $segment  = $das->segment('Chr1');
   my @features = $segment->features;
   my $dna      = $segment->dna;

  # PARALLEL API
  # create a new DAS agent with a timeout of 5 sec
  my $das = Bio::Das->new(5);