Bio/DB/Query/WebQuery.pm

   1 #
   2 # BioPerl module for Bio::DB::WebQuery.pm
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Lincoln Stein <lstein@cshl.org>
   7 #
   8 # Copyright Lincoln Stein
   9 #
  10 # You may distribute this module under the same terms as perl itself
  11 #
  12 # POD documentation - main docs before the code
  13 #
  14
  15 =head1 NAME
  16
  17 Bio::DB::Query::WebQuery - Helper class for web-based sequence queryies
  18
  19 =head1 SYNOPSIS
  20
  21   # Do not use this class directly.  See Bio::DB::QueryI and one of
  22   # the implementor classes (such as Bio::DB::GenBankQuery) for
  23   # information.
  24
  25 See L<Bio::DB::QueryI>, L<Bio::DB::GenBankQuery>
  26
  27
  28 =head1 DESCRIPTION
  29
  30 Do not use this class directly.  See Bio::DB::QueryI and one of the
  31 implementor classes (such as Bio::DB::Query::GenBank) for information.
  32
  33 Those writing subclasses must define _get_params() and
  34 _parse_response(), and possibly override _request_method().
  35
  36 =head1 FEEDBACK
  37
  38 =head2 Mailing Lists
  39
  40 User feedback is an integral part of the
  41 evolution of this and other Bioperl modules. Send
  42 your comments and suggestions preferably to one
  43 of the Bioperl mailing lists. Your participation
  44 is much appreciated.
  45
  46   bioperl-l@bioperl.org                  - General discussion
  47   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  48
  49 =head2 Support
  50
  51 Please direct usage questions or support issues to the mailing list:
  52
  53 I<bioperl-l@bioperl.org>
  54
  55 rather than to the module maintainer directly. Many experienced and
  56 reponsive experts will be able look at the problem and quickly
  57 address it. Please include a thorough description of the problem
  58 with code and data examples if at all possible.
  59
  60 =head2 Reporting Bugs
  61
  62 Report bugs to the Bioperl bug tracking system to help us keep track
  63 the bugs and their resolution.  Bug reports can be submitted via the
  64 web:
  65
  66   https://github.com/bioperl/bioperl-live/issues
  67
  68 =head1 AUTHOR - Lincoln Stein
  69
  70 Email lstein@cshl.org
  71
  72 =head1 APPENDIX
  73
  74 The rest of the documentation details each of the
  75 object methods. Internal methods are usually
  76 preceded with a _
  77
  78 =cut
  79
  80 # Let the code begin...
  81
  82 package Bio::DB::Query::WebQuery;
  83 use strict;
  84 use URI;
  85 use LWP::UserAgent;
  86 use HTTP::Request::Common;
  87
  88 use base qw(Bio::Root::Root Bio::DB::QueryI);
  89
  90 =head2 new
  91
  92  Title   : new
  93  Usage   : $db = Bio::DB::WebQuery->new(@args)
  94  Function: create new query object
  95  Returns : new query object
  96  Args    : -db       database (e.g. 'protein')
  97            -ids      array ref of ids (overrides query)
  98            -verbose  turn on verbose debugging
  99
 100 This method creates a new query object.  Typically you will specify a
 101 -db and a -query argument.  The value of -query is a database-specific
 102 string.
 103
 104 If you provide an array reference of IDs in -ids, the query will be
 105 ignored and the list of IDs will be used when the query is passed to
 106 the database.
 107
 108 =cut
 109
 110 # Borrowed shamelessly from WebDBSeqI.  Some of this code should be
 111 # refactored.
 112 sub new {
 113   my $class = shift;
 114   my $self  = $class->SUPER::new(@_);
 115
 116   my ($query,$ids,$verbose) = $self->_rearrange(['QUERY','IDS','VERBOSE'],@_);
 117   $self->throw('must provide one of the the -query or -ids arguments')
 118     unless defined($query) || defined($ids);
 119   if ($ids) {
 120     $query = $self->_generate_id_string($ids);
 121   }
 122   $self->query($query);
 123   $verbose && $self->verbose($verbose);
 124
 125   my $ua = LWP::UserAgent->new(env_proxy => 1);
 126   $ua->agent(ref($self) ."/".($Bio::DB::Query::WebQuery::VERSION || '0.1'));
 127   $self->ua($ua);
 128   $self->{'_authentication'} = [];
 129   $self;
 130 }
 131
 132 =head2 ua
 133
 134  Title   : ua
 135  Usage   : my $ua = $self->ua or
 136            $self->ua($ua)
 137  Function: Get/Set a LWP::UserAgent for use
 138  Returns : reference to LWP::UserAgent Object
 139  Args    : $ua - must be a LWP::UserAgent
 140
 141 =cut
 142
 143 sub ua {
 144    my ($self, $ua) = @_;
 145    my $d = $self->{'_ua'};
 146    if( defined $ua && $ua->isa("LWP::UserAgent") ) {
 147       $self->{'_ua'} = $ua;
 148    }
 149    $d;
 150 }
 151
 152 =head2 proxy
 153
 154  Title   : proxy
 155  Usage   : $httpproxy = $db->proxy('http')  or
 156            $db->proxy(['http','ftp'], 'http://myproxy' )
 157  Function: Get/Set a proxy for use of proxy
 158  Returns : a string indicating the proxy
 159  Args    : $protocol : an array ref of the protocol(s) to set/get
 160            $proxyurl : url of the proxy to use for the specified protocol
 161            $username : username (if proxy requires authentication)
 162            $password : password (if proxy requires authentication)
 163
 164 =cut
 165
 166 sub proxy {
 167     my ($self,$protocol,$proxy,$username,$password) = @_;
 168     return undef if ( !defined $self->ua || !defined $protocol
 169                       || !defined $proxy );
 170     $self->authentication($username, $password)
 171         if ($username && $password);
 172     return $self->ua->proxy($protocol,$proxy);
 173 }
 174
 175 =head2 authentication
 176
 177  Title   : authentication
 178  Usage   : $db->authentication($user,$pass)
 179  Function: Get/Set authentication credentials
 180  Returns : Array of user/pass
 181  Args    : Array or user/pass
 182
 183
 184 =cut
 185
 186 sub authentication{
 187    my ($self,$u,$p) = @_;
 188
 189    if( defined $u && defined $p ) {
 190        $self->{'_authentication'} = [ $u,$p];
 191    }
 192    return @{$self->{'_authentication'}};
 193 }
 194
 195 =head2 ids
 196
 197  Title   : ids
 198  Usage   : @ids = $db->ids([@ids])
 199  Function: get/set matching ids
 200  Returns : array of sequence ids
 201  Args    : (optional) array ref with new set of ids
 202
 203 =cut
 204
 205 sub ids     {
 206   my $self = shift;
 207   if (@_) {
 208     my $d = $self->{'_ids'};
 209     my $arg = shift;
 210     $self->{'_ids'} = ref $arg ? $arg : [$arg];
 211     return $d ? @$d : ();
 212   } else {
 213     $self->_fetch_ids;
 214     return @{$self->{'_ids'} || []};
 215   }
 216 }
 217
 218 =head2 query
 219
 220  Title   : query
 221  Usage   : $query = $db->query([$query])
 222  Function: get/set query string
 223  Returns : string
 224  Args    : (optional) new query string
 225
 226 =cut
 227
 228 sub query   {
 229   my $self = shift;
 230   my $d    = $self->{'_query'};
 231   $self->{'_query'} = shift if @_;
 232   $d;
 233 }
 234
 235 =head2 _fetch_ids
 236
 237  Title   : _fetch_ids
 238  Usage   : @ids = $db->_fetch_ids
 239  Function: run query, get ids
 240  Returns : array of sequence ids
 241  Args    : none
 242
 243 =cut
 244
 245 sub _fetch_ids     {
 246   my $self = shift;
 247   $self->_run_query;
 248   $self->_run_query(1) if $self->_truncated;
 249   $self->throw('Id list has been truncated even after maxids requested')
 250     if $self->_truncated;
 251   return @{$self->{'_ids'}} if $self->{'_ids'};
 252 }
 253
 254 =head2 _run_query
 255
 256  Title   : _run_query
 257  Usage   : $success = $db->_run_query
 258  Function: run query, parse results
 259  Returns : true if successful
 260  Args    : none
 261
 262 =cut
 263
 264 sub _run_query {
 265   my $self   = shift;
 266   my $force  = shift;
 267
 268   # allow the query to be run one extra time if truncated
 269   return $self->{'_ran_query'} if $self->{'_ran_query'}++ && !$force;
 270
 271   my $request = $self->_get_request;
 272   $self->debug("request is ".$request->url."\n");
 273   my $response = $self->ua->request($request);
 274   return unless $response->is_success;
 275   $self->debug("response is ".$response->content."\n");
 276   $self->_parse_response($response->content);
 277   1;
 278 }
 279
 280 =head2 _truncated
 281
 282  Title   : _truncated
 283  Usage   : $flag = $db->_truncated([$newflag])
 284  Function: get/set truncation flag
 285  Returns : boolean
 286  Args    : new flag
 287
 288 Some databases will truncate output unless explicitly asked
 289 not to.  This flag allows a "two probe" attempt.
 290
 291 =cut
 292
 293 sub _truncated {
 294   my $self = shift;
 295   my $d = $self->{'_truncated'};
 296   $self->{'_truncated'} = shift if @_;
 297   $d;
 298 }
 299
 300 =head2 _get_request
 301
 302  Title   : _get_request
 303  Usage   : $http_request = $db->_get_request(@params)
 304  Function: create an HTTP::Request with indicated parameters
 305  Returns : HTTP::Request object
 306  Args    : CGI parameter list
 307
 308 =cut
 309
 310 sub _get_request {
 311   my $self   = shift;
 312   my ($method,$base,@params) = $self->_request_parameters;
 313   my $uri = URI->new($base);
 314   my $request;
 315   if ($method eq 'get') {
 316     $uri->query_form(@params);
 317     $request = GET $uri;
 318   } else {
 319     $request = POST $uri,\@params;
 320   }
 321
 322   $request->proxy_authorization_basic($self->authentication)
 323         if $self->authentication;
 324   $request;
 325 }
 326
 327 =head2 _parse_response
 328
 329  Title   : _parse_response
 330  Usage   : $db->_parse_response($content)
 331  Function: parse out response
 332  Returns : empty
 333  Args    : none
 334  Throws  : 'unparseable output exception'
 335
 336 NOTE: This method must be implemented by subclass.
 337
 338 =cut
 339
 340 sub _parse_response {
 341   my $self    = shift;
 342   my $content = shift;
 343   $self->throw_not_implemented;
 344 }
 345
 346 =head2 _request_parameters
 347
 348  Title   : _request_parameters
 349  Usage   : ($method,$base,@params = $db->_request_parameters
 350  Function: return information needed to construct the request
 351  Returns : list of method, url base and key=>value pairs
 352  Args    : none
 353
 354 NOTE: This method must be implemented by subclass.
 355
 356 =cut
 357
 358 sub _request_parameters {
 359   my $self = shift;
 360   $self->throw_not_implemented;
 361 }
 362
 363 =head2 _generate_id_string
 364
 365  Title   : _generate_id_string
 366  Usage   : $string = $db->_generate_id_string
 367  Function: joins IDs together in string (implementation-dependent)
 368  Returns : string of concatenated IDs
 369  Args    : array ref of ids (normally passed into the constructor)
 370
 371 NOTE: This method must be implemented by subclass.
 372
 373 =cut
 374
 375 sub _generate_id_string {
 376   my $self = shift;
 377   $self->throw_not_implemented;
 378 }
 379
 380 1;