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