view release on metacpan or  search on metacpan

Bio/DB/GenericWebAgent.pm  view on Meta::CPAN

           likely set specific parameters in their constructor;
           Bio::DB::GenericWebAgent is primarily a test bed.

=cut

sub new {
    my ($class, @args) = @_;
    my $self = $class->SUPER::new(@args);
    $self->ua(LWP::UserAgent->new(env_proxy => 1,
            agent => ref($self)));
    $self->delay($self->delay_policy);
    return $self;
}

=head1 GenericWebAgent methods

=head2 parameter_base

 Title   : parameter_base
 Usage   : $dbi->parameter_base($pobj);
 Function: Get/Set Bio::ParameterBaseI.
 Returns : Bio::ParameterBaseI object
 Args    : Bio::ParameterBaseI object

=cut

# this will likely be overridden in subclasses

sub parameter_base {
    my ($self, $pobj) = @_;
    if ($pobj) {
        $self->throw('Not a Bio::ParameterBaseI')
            if !$pobj->isa('Bio::ParameterBaseI');
        $self->{'_parameter_base'} = $pobj;
    }
    return $self->{'_parameter_base'};
}

=head2 ua

 Title   : ua
 Usage   : $dbi->ua;
 Function: Get/Set LWP::UserAgent.
 Returns : LWP::UserAgent
 Args    : LWP::UserAgent

=cut

sub ua {
	my ($self, $ua) = @_;
	if( defined $ua && $ua->isa("LWP::UserAgent") ) {
		$self->{'_ua'} = $ua;
	}
	return $self->{'_ua'};
}

=head2 get_Response

 Title   : get_Response
 Usage   : $agent->get_Response;
 Function: Get the HTTP::Response object by passing it an HTTP::Request (generated from
           Bio::ParameterBaseI implementation).
 Returns : HTTP::Response object or data if callback is used
 Args    : (optional)

           -cache_response - flag to cache HTTP::Response object;
                             Default is 1 (TRUE, caching ON)

           These are passed on to LWP::UserAgent::request() if stipulated

           -cb     - use a LWP::UserAgent-compliant callback
           -file   - dumps the response to a file (handy for large responses)
                     Note: can't use file and callback at the same time
           -read_size_hint - bytes of content to read in at a time to pass to callback
 Note    : Caching and parameter checking are set

=cut

# TODO deal with small state-related bug with file

sub get_Response {
    my ($self, @args) = @_;
    my ($cache, $file, $cb, $size) = $self->_rearrange([qw(CACHE_RESPONSE FILE CB READ_SIZE_HINT)],@args);
    $self->throw("Can't have both callback and file") if $file && $cb;
    # make -file accept more perl-like write-append type data.
    $file =~ s{^>}{} if $file;
    my @opts = grep {defined $_} ($file || $cb, $size);
    $cache = (defined $cache && $cache == 0) ? 0 : 1;
    my $pobj = $self->parameter_base;
    if ($pobj->parameters_changed ||
        !$cache  ||
        !$self->{_response_cache} ||
        !$self->{_response_cache}->content) {
        my $ua = $self->ua;
        $self->_sleep; # institute delay policy
        $self->throw('No parameter object set; cannot form a suitable remote request') unless $pobj;
        my $request = $pobj->to_request;
        if ($self->authentication) {
            $request->proxy_authorization_basic($self->authentication)
        }
        $self->debug("Request is: \n",$request->as_string);
        # I'm relying on the useragent to throw the proper errors here
        my $response = $ua->request($request, @opts);
        if ($response->is_error) {
            $self->throw("Response Error\n".$response->message);
        }
        return $self->{_response_cache} = $response;
    } else {
        $self->debug("Returning cached HTTP::Response object\n");
        if ($file) {
            $self->_dump_request_content($file);
            # size isn't passed here, as the content is completely retrieved above
        } elsif ($cb) {
            $cb && ref($cb) eq 'CODE' && $cb->($self->{_response_cache}->content);
        }
        return $self->{_response_cache};
    }
}

=head2 get_Parser