~ubuntu-branches/ubuntu/oneiric/bioperl/oneiric

« back to all changes in this revision

Viewing changes to Bio/DB/GenericWebDBI.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2009-03-10 07:19:11 UTC
  • mfrom: (3.1.2 squeeze)
  • Revision ID: james.westby@ubuntu.com-20090310071911-ever3si2bbzx1iks
Tags: 1.6.0-2
* Removed patch system (not used):
  - removed instuctions in debian/rules;
  - removed quilt from Build-Depends in debian/control.
* Re-enabled tests:
  - uncommented test command in debian/rules;
  - uncommented previously missing build-dependencies in debian/control.
  - Re-enabled tests and uncommented build-dependencies accordingly.
* Removed libmodule-build-perl and libtest-harness-perl from
  Build-Depends-Indep (provided by perl-modules).
* Better cleaning of empty directories using find -type d -empty -delete
  instead of rmdir in debian/rules (LP: #324001).

Show diffs side-by-side

added added

removed removed

Lines of Context:
1
 
# $Id: GenericWebDBI.pm,v 1.3.4.1 2006/10/02 23:10:15 sendu Exp $
2
 
#
3
 
# BioPerl module for Bio::DB::EUtilities
4
 
#
5
 
# Cared for by Chris Fields <cjfields at uiuc dot edu>
6
 
#
7
 
# Copyright Chris Fields
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
 
# Interfaces with new GenericWebDBI interface
14
 
 
15
 
=head1 NAME
16
 
 
17
 
Bio::DB::GenericWebDBI - abstract interface for parameter-based remote
18
 
database access
19
 
 
20
 
=head1 SYNOPSIS
21
 
 
22
 
  #
23
 
  # grab data from HTTP::Response object using concrete class
24
 
  #
25
 
 
26
 
  $data = $db->get_response->content;
27
 
 
28
 
  #
29
 
  # $data is the raw data output from the HTTP::Response object;
30
 
  # this data may be preparsed using the private method _parse_response
31
 
 
32
 
=head1 DESCRIPTION
33
 
 
34
 
WARNING: Please do B<NOT> spam the web servers with multiple requests.
35
 
 
36
 
This class acts as a user agent interface for any generic web database, but
37
 
is specifically geared towards CGI-based databases which accept parameters.
38
 
 
39
 
=head1 TODO
40
 
 
41
 
File and filehandle support to be added
42
 
 
43
 
Any feedback is welcome.
44
 
 
45
 
=head1 FEEDBACK
46
 
 
47
 
=head2 Mailing Lists
48
 
 
49
 
User feedback is an integral part of the
50
 
evolution of this and other Bioperl modules. Send
51
 
your comments and suggestions preferably to one
52
 
of the Bioperl mailing lists. Your participation
53
 
is much appreciated.
54
 
 
55
 
  bioperl-l@lists.open-bio.org               - General discussion
56
 
  http://www.bioperl.org/wiki/Mailing_lists  - About the mailing lists
57
 
 
58
 
=head2 Reporting Bugs
59
 
 
60
 
Report bugs to the Bioperl bug tracking system to
61
 
help us keep track the bugs and their resolution.
62
 
Bug reports can be submitted via the web.
63
 
 
64
 
  http://bugzilla.open-bio.org/
65
 
 
66
 
=head1 AUTHOR
67
 
 
68
 
Email cjfields at uiuc dot edu
69
 
 
70
 
=head1 APPENDIX
71
 
 
72
 
The rest of the documentation details each of the
73
 
object methods. Internal methods are usually
74
 
preceded with a _
75
 
 
76
 
=cut
77
 
 
78
 
# Let the code begin...
79
 
 
80
 
package Bio::DB::GenericWebDBI;
81
 
use strict;
82
 
use warnings;
83
 
use vars qw($MODVERSION %RETRIEVAL_TYPES $DEFAULT_RETRIEVAL_TYPE
84
 
         $DEFAULT_RETURN_FORMAT $LAST_INVOCATION_TIME);
85
 
 
86
 
use base qw(Bio::Root::Root LWP::UserAgent);
87
 
 
88
 
BEGIN {
89
 
    $MODVERSION = '0.8';
90
 
    %RETRIEVAL_TYPES = ('io_string' => 1,
91
 
                'tempfile'  => 1,
92
 
                'pipeline'  => 1,
93
 
                );
94
 
    $DEFAULT_RETRIEVAL_TYPE = 'pipeline';
95
 
    $DEFAULT_RETURN_FORMAT = 'text';
96
 
    $LAST_INVOCATION_TIME = 0;
97
 
}
98
 
 
99
 
sub new {
100
 
    my ($class, @args) = @_;
101
 
    my $self = $class->SUPER::new(@args);
102
 
    my ($url_base, $retmode, $delay, $db) =
103
 
        $self->_rearrange([qw(URL_BASE RETMODE DELAY DB)],
104
 
        @args);
105
 
    # from LWP::UserAgent; set agent and env proxy
106
 
    $self->agent(ref($self)."/$Bio::Root::Root::VERSION");
107
 
    $self->env_proxy;
108
 
    $db             && $self->db($db);
109
 
    # these will likely be overridden in base classes
110
 
    $retmode        && $self->retmode($retmode);
111
 
    $url_base       && $self->url_base_address($url_base);
112
 
    # delay policy needs to be worked out; not set up correctly
113
 
    $delay = defined($delay) ? $delay: $self->delay_policy;
114
 
    $self->delay($delay);
115
 
    return $self;
116
 
}
117
 
 
118
 
=head2 url_base_address
119
 
 
120
 
 Title   : url_base_address
121
 
 Usage   : my $address = $self->url_base_address or
122
 
           $self->url_base_address($address)
123
 
 Function: Get/Set the base URL for the Web Database
124
 
 Returns : Base URL for the Web Database
125
 
 Args    : $address - URL for the WebDatabase
126
 
 
127
 
=cut
128
 
 
129
 
sub url_base_address {
130
 
    my $self = shift;
131
 
    return $self->{'_baseaddress'} = shift if @_;
132
 
    return $self->{'_baseaddress'};
133
 
}
134
 
 
135
 
=head2 proxy
136
 
 
137
 
 Title   : proxy
138
 
 Usage   : $httpproxy = $db->proxy('http')  or
139
 
           $db->proxy(['http','ftp'], 'http://myproxy' )
140
 
 Function: Get/Set a proxy for use of proxy
141
 
 Returns : a string indicating the proxy
142
 
 Args    : $protocol : an array ref of the protocol(s) to set/get
143
 
           $proxyurl : url of the proxy to use for the specified protocol
144
 
           $username : username (if proxy requires authentication)
145
 
           $password : password (if proxy requires authentication)
146
 
 
147
 
=cut
148
 
 
149
 
sub proxy {
150
 
    my ($self,$protocol,$proxy,$username,$password) = @_;
151
 
    return undef if ( !defined $protocol || !defined $proxy );
152
 
    $self->authentication($username, $password)
153
 
    if ($username && $password);
154
 
    return $self->SUPER::proxy($protocol,$proxy);
155
 
}
156
 
 
157
 
=head2 authentication
158
 
 
159
 
 Title   : authentication
160
 
 Usage   : $db->authentication($user,$pass)
161
 
 Function: Get/Set authentication credentials
162
 
 Returns : Array of user/pass
163
 
 Args    : Array or user/pass
164
 
 
165
 
=cut
166
 
 
167
 
sub authentication{
168
 
   my ($self,$u,$p) = @_;
169
 
   if( defined $u && defined $p ) {
170
 
       $self->{'_authentication'} = [ $u,$p];
171
 
   }
172
 
   return @{$self->{'_authentication'}};
173
 
}
174
 
 
175
 
=head2 db
176
 
 
177
 
 Title   : db
178
 
 Usage   : $db->db
179
 
 Function: Get/Set database parameter
180
 
 Returns : string
181
 
 Args    : optional string
182
 
 
183
 
=cut
184
 
 
185
 
sub db {
186
 
        my $self = shift;
187
 
        return $self->{'_db'} = shift if @_;
188
 
        return $self->{'_db'};
189
 
}
190
 
 
191
 
=head2 id
192
 
 
193
 
 Title   : id
194
 
 Usage   : $agent->id($id)
195
 
           $agent->id(\@id)
196
 
 Function: Get/Set id(s)
197
 
 Returns : reference to id(s)
198
 
 Args    : a single id or reference to array of id(s)
199
 
 
200
 
=cut
201
 
 
202
 
sub id {
203
 
        my $self = shift;
204
 
    if (@_) {
205
 
        my $id = shift;
206
 
        if (ref($id) !~ /ARRAY/) { # single ID
207
 
            $self->{'_ids'} = [$id];
208
 
        }
209
 
        else {
210
 
            $self->{'_ids'} = $id;
211
 
        }
212
 
    }
213
 
        return $self->{'_ids'};
214
 
}
215
 
 
216
 
=head2 retmode
217
 
 
218
 
 Title   : retmode
219
 
 Usage   : $agent->retmode($mode)
220
 
 Function: Get/Set return mode for query (text, xml, html, asn.1, etc)
221
 
 Returns : string for return mode
222
 
 Args    : optional string
223
 
 
224
 
=cut
225
 
 
226
 
sub retmode {
227
 
        my $self = shift;
228
 
        return $self->{'_retmode'} = shift if @_;
229
 
        return $self->{'_retmode'};
230
 
}
231
 
 
232
 
=head2 get_response
233
 
 
234
 
 Title   : get_response
235
 
 Usage   : $agent->get_response;
236
 
 Function: get the request based on set object parameters, retrieved using
237
 
           the private method _get_params
238
 
 Returns : HTTP::Response object
239
 
 Args    : none
240
 
 
241
 
 This is implemented by the derived class
242
 
 
243
 
=cut
244
 
 
245
 
sub get_response {
246
 
    my ($self) = @_;
247
 
    my $msg = "Implementing class must define method get_response in class GenericWebDBI";
248
 
    $self->throw($msg);
249
 
}
250
 
 
251
 
=head2 delay
252
 
 
253
 
 Title   : delay
254
 
 Usage   : $secs = $self->delay([$secs])
255
 
 Function: get/set number of seconds to delay between fetches
256
 
 Returns : number of seconds to delay
257
 
 Args    : new value
258
 
 
259
 
NOTE: the default is to use the value specified by delay_policy().
260
 
This can be overridden by calling this method, or by passing the
261
 
-delay argument to new().
262
 
 
263
 
=cut
264
 
 
265
 
sub delay {
266
 
   my $self = shift;
267
 
   return $self->{'_delay'} = shift if @_;
268
 
   return $self->{'_delay'};
269
 
}
270
 
 
271
 
=head2 delay_policy
272
 
 
273
 
 Title   : delay_policy
274
 
 Usage   : $secs = $self->delay_policy
275
 
 Function: return number of seconds to delay between calls to remote db
276
 
 Returns : number of seconds to delay
277
 
 Args    : none
278
 
 
279
 
NOTE: The default delay policy is 0s.  Override in subclasses to
280
 
implement delays.  The timer has only second resolution, so the delay
281
 
will actually be +/- 1s.
282
 
 
283
 
=cut
284
 
 
285
 
sub delay_policy {
286
 
   my $self = shift;
287
 
   return 0;
288
 
}
289
 
 
290
 
=head2 _submit_request
291
 
 
292
 
  Title   : _submit_request
293
 
  Usage   : my $url = $self->get_request
294
 
  Function: builds request object based on set parameters
295
 
  Returns : HTTP::Request
296
 
  Args    : optional : Bio::DB::EUtilities cookie
297
 
 
298
 
=cut
299
 
 
300
 
sub _submit_request {
301
 
    my ($self) = @_;
302
 
    my $msg = "Implementing class must define method _submit_request in class GenericWebDBI";
303
 
    $self->throw($msg);
304
 
}
305
 
 
306
 
=head2 _get_params
307
 
 
308
 
  Title   : _get_params
309
 
  Usage   : my $url = $self->_get_params
310
 
  Function: builds parameter list for web request
311
 
  Returns : hash of parameter-value paris
312
 
  Args    : optional : Bio::DB::EUtilities cookie
313
 
 
314
 
=cut
315
 
 
316
 
# these get sorted out in a hash originally but end up in an array to
317
 
# deal with multiple id parameters (hash values would kill that)
318
 
 
319
 
sub _get_params {
320
 
    my ($self) = @_;
321
 
    my $msg = "Implementing class must define method _get_params in class GenericWebDBI";
322
 
    $self->throw($msg);
323
 
}
324
 
 
325
 
=head2 _sleep
326
 
 
327
 
 Title   : _sleep
328
 
 Usage   : $self->_sleep
329
 
 Function: sleep for a number of seconds indicated by the delay policy
330
 
 Returns : none
331
 
 Args    : none
332
 
 
333
 
NOTE: This method keeps track of the last time it was called and only
334
 
imposes a sleep if it was called more recently than the delay_policy()
335
 
allows.
336
 
 
337
 
=cut
338
 
 
339
 
sub _sleep {
340
 
   my $self = shift;
341
 
   my $last_invocation = $LAST_INVOCATION_TIME;
342
 
   if (time - $LAST_INVOCATION_TIME < $self->delay) {
343
 
      my $delay = $self->delay - (time - $LAST_INVOCATION_TIME);
344
 
      $self->debug("sleeping for $delay seconds\n");
345
 
      sleep $delay;
346
 
   }
347
 
   $LAST_INVOCATION_TIME = time;
348
 
}
349
 
 
350
 
1;
351
 
__END__