Permalink
Browse files

finish moving the Bio-DB-EUtilities to the Bio-EUtilities repository

  • Loading branch information...
1 parent 9bc9b02 commit d6dd39f35c21ae6222171f5af2867c4c460934e2 @carandraug carandraug committed Jan 28, 2013
Showing with 0 additions and 1,561 deletions.
  1. +0 −372 Bio/DB/GenericWebAgent.pm
  2. +0 −106 scripts/Bio-DB-EUtilities/bp_einfo.pl
  3. +0 −1,083 scripts/Bio-DB-EUtilities/bp_genbank_ref_extractor.pl
View
@@ -1,372 +0,0 @@
-#
-# BioPerl module for Bio::DB::GenericWebAgent
-#
-# Please direct questions and support issues to <bioperl-l@bioperl.org>
-#
-# Cared for by Chris Fields <cjfields at bioperl dot org>
-#
-# Copyright Chris Fields
-#
-# You may distribute this module under the same terms as perl itself
-#
-# POD documentation - main docs before the code
-#
-# Interfaces with new GenericWebAgent interface
-
-=head1 NAME
-
-Bio::DB::GenericWebAgent - helper base class for parameter-based remote server
-access and response retrieval.
-
-=head1 SYNOPSIS
-
- # DO NOT USE DIRECTLY
-
- See Bio::DB::EUtilities for an example implementation
-
-=head1 DESCRIPTION
-
-WARNING: Please do B<NOT> spam the web servers with multiple requests.
-
-Bio::DB::GenericWebAgent is a generic wrapper around a web agent
-(LWP::UserAgent), an object which can retain, format, and build parameters for
-the user agent (Bio::ParameterBaseI), and a BioPerl class parser that processes
-response content received by the user agent. The Bio::ParameterBaseI object
-should be state-aware, e.g. know when changes occur to parameters, so that
-identical requests are not repeatedly sent to the server (this base class takes
-this into consideration).
-
-=head1 FEEDBACK
-
-=head2 Mailing Lists
-
-User feedback is an integral part of the
-evolution of this and other Bioperl modules. Send
-your comments and suggestions preferably to one
-of the Bioperl mailing lists. Your participation
-is much appreciated.
-
- bioperl-l@lists.open-bio.org - General discussion
- http://www.bioperl.org/wiki/Mailing_lists - About the mailing lists
-
-=head2 Support
-
-Please direct usage questions or support issues to the mailing list:
-
-I<bioperl-l@bioperl.org>
-
-rather than to the module maintainer directly. Many experienced and
-reponsive experts will be able look at the problem and quickly
-address it. Please include a thorough description of the problem
-with code and data examples if at all possible.
-
-=head2 Reporting Bugs
-
-Report bugs to the Bioperl bug tracking system to
-help us keep track the bugs and their resolution.
-Bug reports can be submitted via the web.
-
- https://redmine.open-bio.org/projects/bioperl/
-
-=head1 AUTHOR
-
-Email cjfields at bioperl dot org
-
-=head1 APPENDIX
-
-The rest of the documentation details each of the
-object methods. Internal methods are usually
-preceded with a _
-
-=cut
-
-# Let the code begin...
-
-package Bio::DB::GenericWebAgent;
-use strict;
-use warnings;
-use base qw(Bio::Root::Root);
-use LWP::UserAgent;
-
-my $LAST_INVOCATION_TIME = 0;
-
-my $TIME_HIRES = 0;
-
-BEGIN {
- eval {
- use Time::HiRes;
- };
- unless ($@) {
- $TIME_HIRES = 1;
- }
-}
-
-=head2 new
-
- Title : new
- Usage : Bio::DB::GenericWebAgent->new(@args);
- Function: Create new Bio::DB::GenericWebAgent instance.
- Returns :
- Args : None specific to this base class. Inheriting classes will
- 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
-
- Title : get_Parser
- Usage : $agent->get_Parser;
- Function: Return HTTP::Response content (file, fh, object) attached to defined parser
- Returns : None
- Args : None
- Note : Abstract method; defined by implementation
-
-=cut
-
-sub get_Parser {
- shift->throw_not_implemented;
-}
-
-=head2 delay
-
- Title : delay
- Usage : $secs = $self->delay($secs)
- Function: get/set number of seconds to delay between fetches
- Returns : number of seconds to delay
- Args : new value
-
-NOTE: the default is to use the value specified by delay_policy().
-This can be overridden by calling this method.
-
-=cut
-
-sub delay {
- my $self = shift;
- return $self->{'_delay'} = shift if @_;
- return $self->{'_delay'};
-}
-
-=head2 delay_policy
-
- Title : delay_policy
- Usage : $secs = $self->delay_policy
- Function: return number of seconds to delay between calls to remote db
- Returns : number of seconds to delay
- Args : none
-
-NOTE: The default delay policy is 3s. Override in subclasses to
-implement delays. The timer has only second resolution, so the delay
-will actually be +/- 1s.
-
-=cut
-
-sub delay_policy {
- my $self = shift;
- return 3;
-}
-
-=head2 _sleep
-
- Title : _sleep
- Usage : $self->_sleep
- Function: sleep for a number of seconds indicated by the delay policy
- Returns : none
- Args : none
-
-NOTE: This method keeps track of the last time it was called and only
-imposes a sleep if it was called more recently than the delay_policy()
-allows.
-
-=cut
-
-sub _sleep {
- my $self = shift;
- my $last_invocation = $LAST_INVOCATION_TIME;
- if (time - $LAST_INVOCATION_TIME < $self->delay) {
- my $delay = $self->delay - (time - $LAST_INVOCATION_TIME);
- $self->debug("sleeping for $delay seconds\n");
- if ($TIME_HIRES) {
- # allows precise sleep timeout (builtin only allows integer seconds)
- Time::HiRes::sleep($delay);
- } else {
- # allows precise sleep timeout (builtin only allows integer seconds)
-
- # I hate this hack , but needed if we support 5.6.1 and
- # don't want additional Time::HiRes prereq
- select undef, undef, undef, $delay;
- }
- }
- $LAST_INVOCATION_TIME = time;
-}
-
-=head1 LWP::UserAgent related methods
-
-=head2 proxy
-
- Title : proxy
- Usage : $httpproxy = $db->proxy('http') or
- $db->proxy(['http','ftp'], 'http://myproxy' )
- Function: Get/Set a proxy for use of proxy
- Returns : a string indicating the proxy
- Args : $protocol : an array ref of the protocol(s) to set/get
- $proxyurl : url of the proxy to use for the specified protocol
- $username : username (if proxy requires authentication)
- $password : password (if proxy requires authentication)
-
-=cut
-
-sub proxy {
- my ($self,$protocol,$proxy,$username,$password) = @_;
- return if ( !defined $protocol || !defined $proxy );
- $self->authentication($username, $password)
- if ($username && $password);
- return $self->ua->proxy($protocol,$proxy);
-}
-
-=head2 authentication
-
- Title : authentication
- Usage : $db->authentication($user,$pass)
- Function: Get/Set authentication credentials
- Returns : Array of user/pass
- Args : Array or user/pass
-
-=cut
-
-sub authentication{
- my ($self,$u,$p) = @_;
- if( defined $u && defined $p ) {
- $self->{'_authentication'} = [ $u,$p];
- }
- $self->{'_authentication'} && return @{$self->{'_authentication'}};
-}
-
-# private method to dump any cached request data content into a passed filename
-
-sub _dump_request_content {
- my ($self, $file) = @_;
- return unless defined $self->{_response_cache};
- $self->throw("Must pass file name") unless $file;
- require Bio::Root::IO;
- my $out = Bio::Root::IO->new(-file => ">$file");
- $out->_print($self->{_response_cache}->content);
- $out->flush();
- $out->close;
-}
-
-1;
Oops, something went wrong.

0 comments on commit d6dd39f

Please sign in to comment.