[Bioperl-guts-l] bioperl-live/Bio/DB EUtilParameters.pm, 1.1, 1.2 EUtilities.pm, 1.37, 1.38 GenericWebDBI.pm, 1.8, 1.9

Christopher John Fields cjfields at dev.open-bio.org
Tue Jun 26 10:38:15 EDT 2007


Update of /home/repository/bioperl/bioperl-live/Bio/DB
In directory dev.open-bio.org:/tmp/cvs-serv16991

Modified Files:
	EUtilParameters.pm EUtilities.pm GenericWebDBI.pm 
Log Message:
commits for overhaul (finally got POST working)

Index: GenericWebDBI.pm
===================================================================
RCS file: /home/repository/bioperl/bioperl-live/Bio/DB/GenericWebDBI.pm,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -d -r1.8 -r1.9
*** GenericWebDBI.pm	20 Dec 2006 22:39:12 -0000	1.8
--- GenericWebDBI.pm	26 Jun 2007 14:38:13 -0000	1.9
***************
*** 15,32 ****
  =head1 NAME
  
! Bio::DB::GenericWebDBI - abstract interface for parameter-based remote
! database access
  
  =head1 SYNOPSIS
  
!   #
!   # grab data from HTTP::Response object using concrete class
!   #
! 
!   $data = $db->get_response->content;
! 
!   #
!   # $data is the raw data output from the HTTP::Response object;
!   # this data may be preparsed using the private method _parse_response
  
  =head1 DESCRIPTION
--- 15,24 ----
  =head1 NAME
  
! Bio::DB::GenericWebDBI - helper base class for parameter-based remote
! access and response retrieval.
  
  =head1 SYNOPSIS
  
! ...
  
  =head1 DESCRIPTION
***************
*** 34,45 ****
  WARNING: Please do B<NOT> spam the web servers with multiple requests.
  
! This class acts as a user agent interface for any generic web database, but
! is specifically geared towards CGI-based databases which accept parameters.
  
  =head1 TODO
  
! File and filehandle support to be added
! 
! Any feedback is welcome.
  
  =head1 FEEDBACK
--- 26,34 ----
  WARNING: Please do B<NOT> spam the web servers with multiple requests.
  
! ...
  
  =head1 TODO
  
! ...
  
  =head1 FEEDBACK
***************
*** 81,249 ****
  use strict;
  use warnings;
! use vars qw($MODVERSION %RETRIEVAL_TYPES $DEFAULT_RETRIEVAL_TYPE
!          $DEFAULT_RETURN_FORMAT $LAST_INVOCATION_TIME);
  
! use base qw(Bio::Root::Root LWP::UserAgent);
  
! BEGIN {
!     $MODVERSION = '0.8';
!     %RETRIEVAL_TYPES = ('io_string' => 1,
!                 'tempfile'  => 1,
!                 'pipeline'  => 1,
!                 );
!     $DEFAULT_RETRIEVAL_TYPE = 'pipeline';
!     $DEFAULT_RETURN_FORMAT = 'text';
!     $LAST_INVOCATION_TIME = 0;
! }
  
  sub new {
      my ($class, @args) = @_;
!     my $self = $class->SUPER::new(@args, env_proxy => 1);
!     my ($url_base, $retmode, $delay, $db) =
!         $self->_rearrange([qw(URL_BASE RETMODE DELAY DB)],
!         @args);
!     # from LWP::UserAgent; set agent and env proxy
!     $self->agent(ref($self)."/$Bio::Root::Root::VERSION");;
!     $db             && $self->db($db);
!     # these will likely be overridden in base classes
!     $retmode        && $self->retmode($retmode);
!     $url_base       && $self->url_base_address($url_base);
!     # delay policy needs to be worked out; not set up correctly
!     $delay = defined($delay) ? $delay: $self->delay_policy;
!     $self->delay($delay);
      return $self;
  }
  
! =head2 url_base_address
! 
!  Title   : url_base_address
!  Usage   : my $address = $self->url_base_address or
!            $self->url_base_address($address)
!  Function: Get/Set the base URL for the Web Database
!  Returns : Base URL for the Web Database
!  Args    : $address - URL for the WebDatabase
! 
! =cut
! 
! sub url_base_address {
!     my $self = shift;
!     return $self->{'_baseaddress'} = shift if @_;
!     return $self->{'_baseaddress'};
! }
  
! =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 undef if ( !defined $protocol || !defined $proxy );
!     $self->authentication($username, $password)
!     if ($username && $password);
!     return $self->SUPER::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];
!    }
!    return @{$self->{'_authentication'}};
  }
  
! =head2 db
  
!  Title   : db
!  Usage   : $db->db
!  Function: Get/Set database parameter
!  Returns : string
!  Args    : optional string
  
  =cut
  
! sub db {
! 	my $self = shift;
! 	return $self->{'_db'} = shift if @_;
! 	return $self->{'_db'};
  }
  
! =head2 id
  
!  Title   : id
!  Usage   : $agent->id($id)
!            $agent->id(\@id)
!  Function: Get/Set id(s)
!  Returns : reference to id(s)
!  Args    : a single id or reference to array of id(s)
  
  =cut
  
! sub id {
! 	my $self = shift;
!     if (@_) {
!         my $id = shift;
!         if (ref($id) !~ /ARRAY/) { # single ID
!             $self->{'_ids'} = [$id];
          }
!         else {
!             $self->{'_ids'} = $id;
          }
      }
! 	return $self->{'_ids'};
! }
! 
! =head2 retmode
! 
!  Title   : retmode
!  Usage   : $agent->retmode($mode)
!  Function: Get/Set return mode for query (text, xml, html, asn.1, etc)
!  Returns : string for return mode
!  Args    : optional string
! 
! =cut
! 
! sub retmode {
! 	my $self = shift;
! 	return $self->{'_retmode'} = shift if @_;
! 	return $self->{'_retmode'};
  }
  
! =head2 get_response
! 
!  Title   : get_response
!  Usage   : $agent->get_response;
!  Function: get the request based on set object parameters, retrieved using
!            the private method _get_params
!  Returns : HTTP::Response object
!  Args    : none
  
!  This is implemented by the derived class
  
  =cut
  
! sub get_response {
!     my ($self) = @_;
!     my $msg = "Implementing class must define method get_response in class GenericWebDBI";
!     $self->throw($msg);
  }
  
--- 70,204 ----
  use strict;
  use warnings;
! use base qw(Bio::Root::Root);
! use LWP::UserAgent;
  
! my $LAST_INVOCATION_TIME = 0;
  
! =head2 new
! 
!  Title   : new
!  Usage   : Bio::DB::GenericWebDBI->new(@args);
!  Function: Create new Bio::DB::GenericWebDBI instance.
!  Returns : 
!  Args    : None specific to this base class.  Inheriting classes will
!            likely set specific parameters in their constructor;
!            Bio::DB::GenericWebDBI 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->VERSION));
!     $self->delay($self->delay_policy);
      return $self;
  }
  
! =head1 GenericWebDBI 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
!            
!            -content_file   - use a LWP::UserAgent-compliant callback
!            -content_cb     - 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
  
! sub get_Response {
!     my ($self, @args) = @_;
!     my ($cache, @opts) = $self->_rearrange([qw(CACHE_RESPONSE CONTENT_FILE CONTENT_CB READ_SIZE_HINT)], at args);
!     $cache = (defined $cache && $cache == 0) ? 0 : 1;
!     my $pobj = $self->parameter_base;
!     if ($pobj->parameters_changed ||
!         !$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,grep {defined $_} @opts);
!         if ($response->is_error) {
!             $self->throw("Response Error\n".$response->message);
          }
+         $self->{_response_cache} = $response;
+     } else {
+         $self->debug("Returning cached HTTP::Response object\n");
      }
!     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;
  }
  
***************
*** 257,262 ****
  
  NOTE: the default is to use the value specified by delay_policy().
! This can be overridden by calling this method, or by passing the
! -delay argument to new().
  
  =cut
--- 212,216 ----
  
  NOTE: the default is to use the value specified by delay_policy().
! This can be overridden by calling this method.
  
  =cut
***************
*** 276,280 ****
   Args    : none
  
! NOTE: The default delay policy is 0s.  Override in subclasses to
  implement delays.  The timer has only second resolution, so the delay
  will actually be +/- 1s.
--- 230,234 ----
   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.
***************
*** 284,323 ****
  sub delay_policy {
     my $self = shift;
!    return 0;
! }
! 
! =head2 _submit_request
! 
!   Title   : _submit_request
!   Usage   : my $url = $self->get_request
!   Function: builds request object based on set parameters
!   Returns : HTTP::Request
!   Args    : optional : Bio::DB::EUtilities cookie
! 
! =cut
! 
! sub _submit_request {
!     my ($self) = @_;
!     my $msg = "Implementing class must define method _submit_request in class GenericWebDBI";
!     $self->throw($msg);
! }
! 
! =head2 _get_params
! 
!   Title   : _get_params
!   Usage   : my $url = $self->_get_params
!   Function: builds parameter list for web request
!   Returns : hash of parameter-value paris
!   Args    : optional : Bio::DB::EUtilities cookie
! 
! =cut
! 
! # these get sorted out in a hash originally but end up in an array to
! # deal with multiple id parameters (hash values would kill that)
! 
! sub _get_params {
!     my ($self) = @_;
!     my $msg = "Implementing class must define method _get_params in class GenericWebDBI";
!     $self->throw($msg);
  }
  
--- 238,242 ----
  sub delay_policy {
     my $self = shift;
!    return 3;
  }
  
***************
*** 347,350 ****
  }
  
  1;
- __END__
--- 266,310 ----
  }
  
+ =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 undef 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'}};
+ }
+ 
  1;

Index: EUtilParameters.pm
===================================================================
RCS file: /home/repository/bioperl/bioperl-live/Bio/DB/EUtilParameters.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** EUtilParameters.pm	12 May 2007 12:04:59 -0000	1.1
--- EUtilParameters.pm	26 Jun 2007 14:38:13 -0000	1.2
***************
*** 51,55 ****
    eutil - the eutil to be used. The default is 'efetch' if not set.
    correspondence - Flag for how IDs are treated. Default is undef (none).
!   cookie - a Bio::DB::EUtilities::Cookie object. Default is undef (none).
  
  At this point minimal checking is done for potential errors in parameter
--- 51,55 ----
    eutil - the eutil to be used. The default is 'efetch' if not set.
    correspondence - Flag for how IDs are treated. Default is undef (none).
!   history - a Bio::Tools::EUtilities::HistoryI object. Default is undef (none).
  
  At this point minimal checking is done for potential errors in parameter
***************
*** 105,109 ****
  
  # eutils only has one hostbase URL
- my $HOSTBASE = 'http://eutils.ncbi.nlm.nih.gov/entrez/eutils/';
  
  # mode : GET or POST (HTTP::Request)
--- 105,108 ----
***************
*** 112,143 ****
  my %MODE = (
      'einfo'     => {
!         'mode'     => 'get',
          'location' => 'einfo.fcgi',
          'params'   => [qw(db retmode tool email)],
                     },
      'epost'     => {
!         'mode'     => 'post',
          'location' => 'epost.fcgi',
          'params'   => [qw(db retmode id tool email)],
                     },
      'efetch'    => {
!         'mode'     => 'get',
          'location' => 'efetch.fcgi',
          'params'   => [qw(db retmode id retmax retstart rettype strand seq_start
!                        seq_stop complexity report tool email )],
                     },
      'esearch'   => {
!         'mode'     => 'get',
          'location' => 'esearch.fcgi',
          'params'   => [qw(db retmode usehistory term field reldate mindate
!                        maxdate datetype retmax retstart rettype sort tool email)],
                     },
      'esummary'  => {
!         'mode'     => 'get',
          'location' => 'esummary.fcgi',
          'params'   => [qw(db retmode id retmax retstart rettype tool email )],
                     },
      'elink'     => {
!         'mode'     => 'get',
          'location' => 'elink.fcgi',
          'params'   => [qw(db retmode id reldate mindate maxdate datetype term 
--- 111,142 ----
  my %MODE = (
      'einfo'     => {
!         'mode'     => 'GET',
          'location' => 'einfo.fcgi',
          'params'   => [qw(db retmode tool email)],
                     },
      'epost'     => {
!         'mode'     => 'POST',
          'location' => 'epost.fcgi',
          'params'   => [qw(db retmode id tool email)],
                     },
      'efetch'    => {
!         'mode'     => 'GET',
          'location' => 'efetch.fcgi',
          'params'   => [qw(db retmode id retmax retstart rettype strand seq_start
!                        seq_stop complexity report tool email)],
                     },
      'esearch'   => {
!         'mode'     => 'GET',
          'location' => 'esearch.fcgi',
          'params'   => [qw(db retmode usehistory term field reldate mindate
!                        maxdate datetype retmax retstart rettype sort tool email WebEnv query_key)],
                     },
      'esummary'  => {
!         'mode'     => 'GET',
          'location' => 'esummary.fcgi',
          'params'   => [qw(db retmode id retmax retstart rettype tool email )],
                     },
      'elink'     => {
!         'mode'     => 'GET',
          'location' => 'elink.fcgi',
          'params'   => [qw(db retmode id reldate mindate maxdate datetype term 
***************
*** 145,154 ****
                     },
      'egquery'   => {
!         'mode'     => 'get',
          'location' => 'egquery.fcgi',
          'params'   => [qw(term retmode tool email)],
                     },
      'espell'    => {
!         'mode'     => 'get',
          'location' => 'espell.fcgi',
          'params'   => [qw(db retmode term tool email )],
--- 144,153 ----
                     },
      'egquery'   => {
!         'mode'     => 'GET',
          'location' => 'egquery.fcgi',
          'params'   => [qw(term retmode tool email)],
                     },
      'espell'    => {
!         'mode'     => 'GET',
          'location' => 'espell.fcgi',
          'params'   => [qw(db retmode term tool email )],
***************
*** 156,204 ****
  );
  
! # used only if cookie is present
! my @COOKIE_PARAMS = qw(db sort seq_start seq_stop strand complexity rettype
      retstart retmax cmd linkname retmode WebEnv query_key);            
  
- # default retmode if one is not supplied
- my %NCBI_DATABASE = (
-     'pubmed'           => 'xml',
-     'protein'          => 'text',
-     'nucleotide'       => 'text',
-     'nuccore'          => 'text',
-     'nucgss'           => 'text',
-     'nucest'           => 'text',
-     'structure'        => 'text',
-     'genome'           => 'text',
-     'books'            => 'xml',
-     'cancerchromosomes'=> 'xml',
-     'cdd'              => 'xml',
-     'domains'          => 'xml',
-     'gene'             => 'asn1',
-     'genomeprj'        => 'xml',
-     'gensat'           => 'xml',
-     'geo'              => 'xml',
-     'gds'              => 'xml',
-     'homologene'       => 'xml',
-     'journals'         => 'text',
-     'mesh'             => 'xml',
-     'ncbisearch'       => 'xml',
-     'nlmcatalog'       => 'xml',
-     'omia'             => 'xml',
-     'omim'             => 'xml',
-     'pmc'              => 'xml',
-     'popset'           => 'xml',
-     'probe'            => 'xml',
-     'pcassay'          => 'xml',
-     'pccompound'       => 'xml',
-     'pcsubstance'      => 'xml',
-     'snp'              => 'xml',
-     'taxonomy'         => 'xml',
-     'unigene'          => 'xml',
-     'unists'           => 'xml',
- );
- 
  my @PARAMS;
  
  # generate getter/setters (will move this into individual ones at some point)
  BEGIN {
      @PARAMS = qw(db id email retmode rettype usehistory term field tool
--- 155,166 ----
  );
  
! # used only if history is present
! my @HISTORY_PARAMS = qw(db sort seq_start seq_stop strand complexity rettype
      retstart retmax cmd linkname retmode WebEnv query_key);            
  
  my @PARAMS;
  
  # generate getter/setters (will move this into individual ones at some point)
+ 
  BEGIN {
      @PARAMS = qw(db id email retmode rettype usehistory term field tool
***************
*** 224,233 ****
      my ($class, @args) = @_;
      my $self = $class->SUPER::new(@args);
      $self->_set_from_args(\@args,
!         -methods => [@PARAMS, qw(eutil cookie correspondence)]);
!     # set default retmode if not explicitly set
      $self->eutil() || $self->eutil('efetch');
!     $self->_set_default_retmode if (!$self->retmode);
!     $self->{'_statechange'} = 1;  
      return $self;
  }
--- 186,196 ----
      my ($class, @args) = @_;
      my $self = $class->SUPER::new(@args);
+     my ($retmode) = $self->_rearrange(["RETMODE"], at args);
      $self->_set_from_args(\@args,
!         -methods => [@PARAMS, qw(eutil history correspondence)]);
      $self->eutil() || $self->eutil('efetch');
!     # set default retmode if not explicitly set    
!     $self->set_default_retmode if (!$retmode);
!     $self->{'_statechange'} = 1;
      return $self;
  }
***************
*** 235,247 ****
  =head1 Bio::ParameterBaseI implemented methods
  
! =head2 
  
   Title   : set_parameters
!  Usage   : $pobj->set_parameters(%params);
   Function: sets the NCBI parameters listed in the hash or array
   Returns : None
   Args    : [optional] hash or array of parameter/values.  
   Note    : This sets any parameter (i.e. doesn't screen them using $MODE or via
!            set cookies).  
  
  =cut
--- 198,210 ----
  =head1 Bio::ParameterBaseI implemented methods
  
! =head2 set_parameters
  
   Title   : set_parameters
!  Usage   : $pobj->set_parameters(@params);
   Function: sets the NCBI parameters listed in the hash or array
   Returns : None
   Args    : [optional] hash or array of parameter/values.  
   Note    : This sets any parameter (i.e. doesn't screen them using $MODE or via
!            set history).
  
  =cut
***************
*** 249,256 ****
  sub set_parameters {
      my ($self, @args) = @_;
!     $self->_set_from_args(\@args, -methods => [@PARAMS]);
  }
  
! =head2 
  
   Title   : reset_parameters
--- 212,223 ----
  sub set_parameters {
      my ($self, @args) = @_;
!     # allow automated resetting; must check to ensure that retmode isn't explicitly passed
!     my $newmode = $self->_rearrange(["RETMODE"], at args);
!     $self->_set_from_args(\@args, -methods => [@PARAMS, qw(eutil correspondence history)]);
!     # set default retmode if not explicitly passed
!     $self->set_default_retmode unless $newmode;
  }
  
! =head2 reset_parameters
  
   Title   : reset_parameters
***************
*** 259,263 ****
   Returns : none
   Args    : [optional] hash of parameter-value pairs
!  Note    : this also resets eutil(), correspondence(), and the cookie and request
             cache
  
--- 226,230 ----
   Returns : none
   Args    : [optional] hash of parameter-value pairs
!  Note    : this also resets eutil(), correspondence(), and the history and request
             cache
  
***************
*** 266,280 ****
  sub reset_parameters {
      my ($self, @args) = @_;
!     # is there a better way of doing this?  probably, but this works
!     for my $param (@PARAMS, qw(eutil correspondence cookie_cache request_cache)) {
!         defined $self->{"_$param"} && undef $self->{"_$param"};
!     }
!     $self->_set_from_args(\@args, -methods => [@PARAMS, qw(eutil correspondence cookie)]);
      $self->eutil() || $self->eutil('efetch');
!     $self->_set_default_retmode if (!$self->retmode);
      $self->{'_statechange'} = 1;
  }
  
! =head2 
  
   Title   : parameters_changed
--- 233,246 ----
  sub reset_parameters {
      my ($self, @args) = @_;
!     # is there a better way of doing this?  probably, but this works...
!     my ($retmode) = $self->_rearrange(["RETMODE"], at args);
!     map { defined $self->{"_$_"} && undef $self->{"_$_"} } (@PARAMS, qw(eutil correspondence history_cache request_cache));
!     $self->_set_from_args(\@args, -methods => [@PARAMS, qw(eutil correspondence history)]);
      $self->eutil() || $self->eutil('efetch');
!     $self->set_default_retmode unless $retmode;
      $self->{'_statechange'} = 1;
  }
  
! =head2 parameters_changed
  
   Title   : parameters_changed
***************
*** 291,295 ****
  }
  
! =head2 
  
   Title   : available_parameters
--- 257,261 ----
  }
  
! =head2 available_parameters
  
   Title   : available_parameters
***************
*** 298,302 ****
   Returns : Array of available parameters (no values)
   Args    : [optional] A string; either eutil name (for returning eutil-specific
!            parameters) or 'cookie' (for those parameters allowed when retrieving
             data stored on the remote server using a 'Cookie').  
  
--- 264,268 ----
   Returns : Array of available parameters (no values)
   Args    : [optional] A string; either eutil name (for returning eutil-specific
!            parameters) or 'history' (for those parameters allowed when retrieving
             data stored on the remote server using a 'Cookie').  
  
***************
*** 308,313 ****
      if ($type eq 'all') {
          return @PARAMS;
!     } elsif ($type eq 'cookie') {
!         return @COOKIE_PARAMS;
      } else {
          $self->throw("$type parameters not supported") if !exists $MODE{$type};
--- 274,279 ----
      if ($type eq 'all') {
          return @PARAMS;
!     } elsif ($type eq 'history') {
!         return @HISTORY_PARAMS;
      } else {
          $self->throw("$type parameters not supported") if !exists $MODE{$type};
***************
*** 316,320 ****
  }
  
! =head2 
  
   Title   : get_parameters
--- 282,286 ----
  }
  
! =head2 get_parameters
  
   Title   : get_parameters
***************
*** 322,330 ****
             %params = $pobj->get_parameters;
   Function: Returns list of key/value pairs, parameter => value
!  Returns : Flattened list of key-value pairs. IDs are returned based on the
!            correspondence value (a string joined by commas or as an array ref).
!  Args    : -type : the eutil name or 'cookie', for returning a subset of
                  parameters (Default: returns all)
-                 
             -join_ids : Boolean; join IDs based on correspondence (Default: no join)
  
--- 288,297 ----
             %params = $pobj->get_parameters;
   Function: Returns list of key/value pairs, parameter => value
!  Returns : Flattened list of key-value pairs. All key-value pairs returned,
!            though subsets can be returned based on the '-type' parameter.  
!            Data passed as an array ref are returned based on whether the
!            '-join_id' flag is set (default is the same array ref). 
!  Args    : -type : the eutil name or 'history', for returning a subset of
                  parameters (Default: returns all)
             -join_ids : Boolean; join IDs based on correspondence (Default: no join)
  
***************
*** 338,342 ****
      my @p;
      for my $param (@final) {
!         if ($param eq 'id' && $join) {
              if ($self->correspondence && $self->eutil eq 'elink') {
                  for my $id_group (@{ $self->id }) {
--- 305,309 ----
      my @p;
      for my $param (@final) {
!         if ($param eq 'id' && $self->id && $join) {
              if ($self->correspondence && $self->eutil eq 'elink') {
                  for my $id_group (@{ $self->id }) {
***************
*** 354,360 ****
                  push @p, ($param => join(',', @{ $self->id }));
              }
!         } elsif ($param eq 'retmode' && !$self->retmode) {
!             
!         } else {
              push @p, ($param => $self->{"_$param"}) if defined $self->{"_$param"};
          }
--- 321,332 ----
                  push @p, ($param => join(',', @{ $self->id }));
              }
!         }
!         elsif ($param eq 'db' && $self->db) {
!             my $db = $self->db;
!             (ref $db eq 'ARRAY') ? 
!                 push @p, ($param => join(',', @{ $db })) :
!                 push @p, ($param => $db) ;
!         }
!         else {
              push @p, ($param => $self->{"_$param"}) if defined $self->{"_$param"};
          }
***************
*** 363,367 ****
  }
  
! =head2 
  
   Title   : to_string
--- 335,341 ----
  }
  
! =head1 Implementation-specific to-* methods
! 
! =head2 to_string
  
   Title   : to_string
***************
*** 370,374 ****
   Returns : String (URL only for now)
   Args    : [optional] 'all'; build URI::http using all parameters
!            Default : Builds based on allowed parameters (presence of cookie data
             or eutil type in %MODE).
   Note    : Changes state of object.  Absolute string
--- 344,348 ----
   Returns : String (URL only for now)
   Args    : [optional] 'all'; build URI::http using all parameters
!            Default : Builds based on allowed parameters (presence of history data
             or eutil type in %MODE).
   Note    : Changes state of object.  Absolute string
***************
*** 387,391 ****
  }
  
! =head2 
  
   Title   : to_request
--- 361,365 ----
  }
  
! =head2 to_request
  
   Title   : to_request
***************
*** 394,400 ****
   Returns : HTTP::Request
   Args    : [optional] 'all'; builds request using all parameters
!            Default : Builds based on allowed parameters (presence of cookie data
             or eutil type in %MODE).
!  Note    : Changes state of object.  Used for CGI-based GET/POST
   
  =cut
--- 368,374 ----
   Returns : HTTP::Request
   Args    : [optional] 'all'; builds request using all parameters
!            Default : Builds based on allowed parameters (presence of history data
             or eutil type in %MODE).
!  Note    : Changes state of object (to boolean FALSE).  Used for CGI-based GET/POST
   
  =cut
***************
*** 402,415 ****
  sub to_request {
      my ($self, $type) = @_;
!     if ($self->parameters_changed || !defined $self->{'_uri_cache'}) {
          my $eutil = $self->eutil;
          $self->throw("No eutil set") if !$eutil;
          #set default retmode
!         my $cookie = ($self->cookie) ? 1 : 0;
!         $type ||= ($cookie) ? 'cookie' : $eutil;
!         my $uri = URI->new($HOSTBASE . $MODE{$eutil}->{location});
!         $uri->query_form($self->get_parameters(-type => $type, -join_ids => 1) );
!         my $method = ($eutil eq 'epost') ? 'POST' : 'GET';
!         my $request = HTTP::Request->new($method => $uri);
          $self->{'_statechange'} = 0;
          $self->{'_request_cache'} = $request;
--- 376,401 ----
  sub to_request {
      my ($self, $type) = @_;
!     if ($self->parameters_changed || !defined $self->{'_request_cache'}) {
          my $eutil = $self->eutil;
          $self->throw("No eutil set") if !$eutil;
          #set default retmode
!         my $history = ($self->history) ? 1 : 0;
!         $type ||= ($history) ? 'history' : $eutil;
!         my ($location, $mode) = ($MODE{$eutil}->{location}, $MODE{$eutil}->{mode});
!         my $request;
!         my $uri = URI->new($self->url_base_address . $location);
!         if ($mode eq 'GET') {
!             $uri->query_form($self->get_parameters(-type => $type, -join_ids => 1) );
!             $request = HTTP::Request->new($mode => $uri);
!             $self->{'_request_cache'} = $request;
!         } elsif ($mode eq 'POST') {
!             $request = HTTP::Request->new($mode => $uri->as_string);
!             $uri->query_form($self->get_parameters(-type => $type, -join_ids => 1) );
!             $request->content_type('application/x-www-form-urlencoded');
!             $request->content($uri->query);
!             $self->{'_request_cache'} = $request;
!         } else {
!             $self->throw("Unrecognized request mode: $mode");
!         }
          $self->{'_statechange'} = 0;
          $self->{'_request_cache'} = $request;
***************
*** 420,424 ****
  =head1 Implementation specific-methods
  
! =head2 
  
   Title   : eutil
--- 406,410 ----
  =head1 Implementation specific-methods
  
! =head2 eutil
  
   Title   : eutil
***************
*** 428,432 ****
   Args    : [optional] string (eutil)
   Throws  : '$eutil not supported' if eutil not present
! 
  =cut
  
--- 414,419 ----
   Args    : [optional] string (eutil)
   Throws  : '$eutil not supported' if eutil not present
!  Note    : This does not reset retmode to the default if called directly.
!  
  =cut
  
***************
*** 441,476 ****
  }
  
! =head2 
  
!  Title   : cookie
!  Usage   : $p->cookie($cookie);
!  Function: gets/sets the cookie (history) to be used for these parameters
!  Returns : Bio::DB::EUtilities::Cookie (if set)
!  Args    : [optional] Bio::DB::EUtilities::Cookie 
!  Throws  : Passed something other than a Bio::DB::EUtilities::Cookie
!  Note    : This overrides WebEnv() and query_key() if set
  
  =cut
  
! # cookie not changed over to ParameterBaseI yet...
! 
! sub cookie {
!     my ($self, $cookie) = @_;
!     if ($cookie) {
!         $self->throw('Not a Bio::DB::EUtilities::Cookie object!') if
!             !$cookie->isa('Bio::DB::EUtilities::Cookie');
!         my ($webenv, $qkey) = @{$cookie->cookie};
!         $webenv     && $self->WebEnv($webenv);
!         $qkey       && $self->query_key($qkey);
! 
!         #TODO: set db(), dbfrom() based on eutil
! 
          $self->{'_statechange'} = 1;
!         $self->{'_cookie_cache'} = $cookie;
      }
!     return $self->{'_cookie_cache'};
  }
  
! =head2 
  
   Title   : correspondence
--- 428,460 ----
  }
  
! =head2 history
  
!  Title   : history
!  Usage   : $p->history($history);
!  Function: gets/sets the history object to be used for these parameters
!  Returns : Bio::Tools::EUtilities::HistoryI (if set)
!  Args    : [optional] Bio::Tools::EUtilities::HistoryI 
!  Throws  : Passed something other than a Bio::Tools::EUtilities::HistoryI 
!  Note    : This overrides WebEnv() and query_key() settings when set
  
  =cut
  
! sub history {
!     my ($self, $history) = @_;
!     if ($history) {
!         $self->throw('Not a Bio::Tools::EUtilities::HistoryI object!') if
!             !$history->isa('Bio::Tools::EUtilities::HistoryI');
!         $self->throw('No history present in HistoryI object') if
!             !$history->has_history;
!         my ($webenv, $qkey) = $history->history;
!         $self->WebEnv($webenv);
!         $self->query_key($qkey);
          $self->{'_statechange'} = 1;
!         $self->{'_history_cache'} = $history;
      }
!     return $self->{'_history_cache'};
  }
  
! =head2 correspondence
  
   Title   : correspondence
***************
*** 491,509 ****
  }
  
! # Title   : _set_default_retmode
! # Usage   : $p->_set_default_retmode();
! # Function: sets retmode to default value if called
! # Returns : none
! # Args    : none
  
! sub _set_default_retmode {
!     my $self = shift;
!     if ($self->eutil eq 'efetch') {
!         my $db = $self->db || $self->throw('No database defined for efetch!');
!         $self->throw('Database $db not recognized') if !exists $NCBI_DATABASE{$db};
!         # set efetch-based retmode
!         $self->retmode($NCBI_DATABASE{$db});
!     } else {
!         $self->retmode('xml');
      }
  }
--- 475,558 ----
  }
  
! =head2 url_base_address
  
!  Title   : url_base_address
!  Usage   : $address = $p->url_base_address();
!  Function: Get URL base address
!  Returns : String
!  Args    : None in this implementation; the URL is fixed
! 
! =cut
! 
! {
!     my $HOSTBASE = 'http://eutils.ncbi.nlm.nih.gov/entrez/eutils/';
!     
!     sub url_base_address {
!         my ($self, $address) = @_;
!         return $HOSTBASE;
!     }
! }
! 
! =head2 set_default_retmode
! 
!  Title   : set_default_retmode
!  Usage   : $p->set_default_retmode();
!  Function: sets retmode to default value specified by the eutil() and the value
!            in %NCBI_DATABASE (for efetch only) if called
!  Returns : none
!  Args    : none
! 
! =cut
! 
! {
!     # default retmode if one is not supplied
!     my %NCBI_DATABASE = (
!         'pubmed'           => 'xml',
!         'protein'          => 'text',
!         'nucleotide'       => 'text',
!         'nuccore'          => 'text',
!         'nucgss'           => 'text',
!         'nucest'           => 'text',
!         'structure'        => 'text',
!         'genome'           => 'text',
!         'books'            => 'xml',
!         'cancerchromosomes'=> 'xml',
!         'cdd'              => 'xml',
!         'domains'          => 'xml',
!         'gene'             => 'asn1',
!         'genomeprj'        => 'xml',
!         'gensat'           => 'xml',
!         'geo'              => 'xml',
!         'gds'              => 'xml',
!         'homologene'       => 'xml',
!         'journals'         => 'text',
!         'mesh'             => 'xml',
!         'ncbisearch'       => 'xml',
!         'nlmcatalog'       => 'xml',
!         'omia'             => 'xml',
!         'omim'             => 'xml',
!         'pmc'              => 'xml',
!         'popset'           => 'xml',
!         'probe'            => 'xml',
!         'pcassay'          => 'xml',
!         'pccompound'       => 'xml',
!         'pcsubstance'      => 'xml',
!         'snp'              => 'xml',
!         'taxonomy'         => 'xml',
!         'unigene'          => 'xml',
!         'unists'           => 'xml',
!     );
! 
!     sub set_default_retmode {
!         my $self = shift;
!         if ($self->eutil eq 'efetch') {
!             my $db = $self->db || return; # assume retmode will be set along with db
!             $self->throw('Database $db not recognized')
!                  if !exists $NCBI_DATABASE{$db};
!             # set efetch-based retmode
!             $self->retmode($NCBI_DATABASE{$db});
!         } else {
!             $self->retmode('xml');
!         }
      }
  }

Index: EUtilities.pm
===================================================================
RCS file: /home/repository/bioperl/bioperl-live/Bio/DB/EUtilities.pm,v
retrieving revision 1.37
retrieving revision 1.38
diff -C2 -d -r1.37 -r1.38
*** EUtilities.pm	20 Dec 2006 22:39:12 -0000	1.37
--- EUtilities.pm	26 Jun 2007 14:38:13 -0000	1.38
***************
*** 11,728 ****
  # POD documentation - main docs before the code
  # 
! # Interfaces with new GenericWebDBI interface 
  
  =head1 NAME
  
! Bio::DB::EUtilities - interface for handling web queries and data
! retrieval from Entrez Utilities at NCBI.
  
  =head1 SYNOPSIS
[...1516 lines suppressed...]
! }
! 
! =head2 callback
! 
!  Title    : callback
!  Usage    : $parser->callback(sub {$_[0]->get_database eq 'protein'});
!  Function : Get/set callback code ref used to filter returned data objects
!  Returns  : code ref if previously set
!  Args     : single argument:
!             code ref - evaluates a passed object and returns true or false value
!                        (used in iterators)
!             'reset' - string, resets the iterator.
!             returns upon any other args
! =cut
! 
! sub callback {
!     my ($self, @args) = @_;
!     return $self->get_Parser->callback(@args);
  }
  



More information about the Bioperl-guts-l mailing list