File Coverage

Bio/DB/Query/WebQuery.pm
Criterion Covered Total %
statement 15 92 16.3
branch 0 40 0.0
condition 0 23 0.0
subroutine 5 18 27.7
pod 6 6 100.0
total 26 179 14.5


line stmt bran cond sub pod time code
1             #
2             # BioPerl module for Bio::DB::WebQuery.pm
3             #
4             # Please direct questions and support issues to
5             #
6             # Cared for by Lincoln Stein
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, L
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
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 3     3   12 use strict;
  3         3  
  3         63  
84 3     3   426 use URI;
  3         1761  
  3         54  
85 3     3   544 use LWP::UserAgent;
  3         25657  
  3         53  
86 3     3   387 use HTTP::Request::Common;
  3         1477  
  3         140  
87              
88 3     3   11 use base qw(Bio::Root::Root Bio::DB::QueryI);
  3         4  
  3         1052  
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 0     0 1   my $class = shift;
114 0           my $self = $class->SUPER::new(@_);
115              
116 0           my ($query,$ids,$verbose) = $self->_rearrange(['QUERY','IDS','VERBOSE'],@_);
117 0 0 0       $self->throw('must provide one of the the -query or -ids arguments')
118             unless defined($query) || defined($ids);
119 0 0         if ($ids) {
120 0           $query = $self->_generate_id_string($ids);
121             }
122 0           $self->query($query);
123 0 0         $verbose && $self->verbose($verbose);
124              
125 0           my $ua = LWP::UserAgent->new(env_proxy => 1);
126 0   0       $ua->agent(ref($self) ."/".($Bio::DB::Query::WebQuery::VERSION || '0.1'));
127 0           $self->ua($ua);
128 0           $self->{'_authentication'} = [];
129 0           $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 0     0 1   my ($self, $ua) = @_;
145 0           my $d = $self->{'_ua'};
146 0 0 0       if( defined $ua && $ua->isa("LWP::UserAgent") ) {
147 0           $self->{'_ua'} = $ua;
148             }
149 0           $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 0     0 1   my ($self,$protocol,$proxy,$username,$password) = @_;
168 0 0 0       return undef if ( !defined $self->ua || !defined $protocol
      0        
169             || !defined $proxy );
170 0 0 0       $self->authentication($username, $password)
171             if ($username && $password);
172 0           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 0     0 1   my ($self,$u,$p) = @_;
188              
189 0 0 0       if( defined $u && defined $p ) {
190 0           $self->{'_authentication'} = [ $u,$p];
191             }
192 0           return @{$self->{'_authentication'}};
  0            
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 0     0 1   my $self = shift;
207 0 0         if (@_) {
208 0           my $d = $self->{'_ids'};
209 0           my $arg = shift;
210 0 0         $self->{'_ids'} = ref $arg ? $arg : [$arg];
211 0 0         return $d ? @$d : ();
212             } else {
213 0           $self->_fetch_ids;
214 0 0         return @{$self->{'_ids'} || []};
  0            
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 0     0 1   my $self = shift;
230 0           my $d = $self->{'_query'};
231 0 0         $self->{'_query'} = shift if @_;
232 0           $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 0     0     my $self = shift;
247 0           $self->_run_query;
248 0 0         $self->_run_query(1) if $self->_truncated;
249 0 0         $self->throw('Id list has been truncated even after maxids requested')
250             if $self->_truncated;
251 0 0         return @{$self->{'_ids'}} if $self->{'_ids'};
  0            
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 0     0     my $self = shift;
266 0           my $force = shift;
267              
268             # allow the query to be run one extra time if truncated
269 0 0 0       return $self->{'_ran_query'} if $self->{'_ran_query'}++ && !$force;
270              
271 0           my $request = $self->_get_request;
272 0           $self->debug("request is ".$request->url."\n");
273 0           my $response = $self->ua->request($request);
274 0 0         return unless $response->is_success;
275 0           $self->debug("response is ".$response->content."\n");
276 0           $self->_parse_response($response->content);
277 0           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 0     0     my $self = shift;
295 0           my $d = $self->{'_truncated'};
296 0 0         $self->{'_truncated'} = shift if @_;
297 0           $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 0     0     my $self = shift;
312 0           my ($method,$base,@params) = $self->_request_parameters;
313 0           my $uri = URI->new($base);
314 0           my $request;
315 0 0         if ($method eq 'get') {
316 0           $uri->query_form(@params);
317 0           $request = GET $uri;
318             } else {
319 0           $request = POST $uri,\@params;
320             }
321              
322 0 0         $request->proxy_authorization_basic($self->authentication)
323             if $self->authentication;
324 0           $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 0     0     my $self = shift;
342 0           my $content = shift;
343 0           $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 0     0     my $self = shift;
360 0           $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 0     0     my $self = shift;
377 0           $self->throw_not_implemented;
378             }
379              
380             1;