lib/Bio/DB/WebDBSeqI.pm

   1 #
   2 # BioPerl module for Bio::DB::WebDBSeqI
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Jason Stajich <jason@bioperl.org>
   7 #
   8 # Copyright Jason Stajich
   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::WebDBSeqI - Object Interface to generalize Web Databases
  18 for retrieving sequences
  19
  20 =head1 SYNOPSIS
  21
  22    # get a WebDBSeqI object somehow
  23    # assuming it is a nucleotide db
  24    my $seq = $db->get_Seq_by_id('ROA1_HUMAN')
  25
  26 =head1 DESCRIPTION
  27
  28 Provides core set of functionality for connecting to a web based
  29 database for retrieving sequences.
  30
  31 Users wishing to add another Web Based Sequence Dabatase will need to
  32 extend this class (see L<Bio::DB::SwissProt> or L<Bio::DB::NCBIHelper> for
  33 examples) and implement the get_request method which returns a
  34 HTTP::Request for the specified uids (accessions, ids, etc depending
  35 on what query types the database accepts).
  36
  37 =head1 FEEDBACK
  38
  39 =head2 Mailing Lists
  40
  41 User feedback is an integral part of the
  42 evolution of this and other Bioperl modules. Send
  43 your comments and suggestions preferably to one
  44 of the Bioperl mailing lists. Your participation
  45 is much appreciated.
  46
  47   bioperl-l@bioperl.org                  - General discussion
  48   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  49
  50 =head2 Support
  51
  52 Please direct usage questions or support issues to the mailing list:
  53
  54 I<bioperl-l@bioperl.org>
  55
  56 rather than to the module maintainer directly. Many experienced and
  57 reponsive experts will be able look at the problem and quickly
  58 address it. Please include a thorough description of the problem
  59 with code and data examples if at all possible.
  60
  61 =head2 Reporting Bugs
  62
  63 Report bugs to the Bioperl bug tracking system to
  64 help us keep track the bugs and their resolution.
  65 Bug reports can be submitted via the web.
  66
  67   https://github.com/bioperl/bioperl-live/issues
  68
  69 =head1 AUTHOR - Jason Stajich
  70
  71 Email E<lt> jason@bioperl.org E<gt>
  72
  73 =head1 APPENDIX
  74
  75 The rest of the documentation details each of the
  76 object methods. Internal methods are usually
  77 preceded with a _
  78
  79 =cut
  80
  81 # Let the code begin...
  82
  83 package Bio::DB::WebDBSeqI;
  84
  85 use strict;
  86
  87 use Carp;
  88
  89 use vars qw($MODVERSION %RETRIEVAL_TYPES $DEFAULT_RETRIEVAL_TYPE
  90             $DEFAULTFORMAT $LAST_INVOCATION_TIME @ATTRIBUTES);
  91
  92 use Bio::SeqIO;
  93 use Bio::Root::IO;
  94 use LWP::UserAgent;
  95 use POSIX 'setsid';
  96 use HTTP::Request::Common;
  97 use HTTP::Response;
  98 use File::Spec;
  99 use IO::Pipe;
 100 use IO::String;
 101 use Bio::Root::Root;
 102
 103 use base qw(Bio::DB::RandomAccessI);
 104
 105 BEGIN {
 106         $MODVERSION = '0.8';
 107         %RETRIEVAL_TYPES = ('io_string' => 1,
 108                             'tempfile'  => 1,
 109                             'pipeline'  => 1,
 110                           );
 111         $DEFAULT_RETRIEVAL_TYPE = 'pipeline';
 112         $DEFAULTFORMAT = 'fasta';
 113         $LAST_INVOCATION_TIME = 0;
 114 }
 115
 116 sub new {
 117     my ($class, @args) = @_;
 118     my $self = $class->SUPER::new(@args);
 119     my ($baseaddress, $params, $ret_type, $format,$delay,$db) =
 120          $self->_rearrange([qw(BASEADDRESS PARAMS RETRIEVALTYPE FORMAT DELAY DB)],
 121                                                          @args);
 122
 123     $ret_type = $DEFAULT_RETRIEVAL_TYPE unless ( $ret_type);
 124     $baseaddress   && $self->url_base_address($baseaddress);
 125     $params        && $self->url_params($params);
 126     $db            && $self->db($db);
 127     $ret_type      && $self->retrieval_type($ret_type);
 128     $delay          = $self->delay_policy unless defined $delay;
 129     $self->delay($delay);
 130
 131
 132     # insure we always have a default format set for retrieval
 133     # even though this will be immedietly overwritten by most sub classes
 134     $format = $self->default_format unless ( defined $format &&
 135                                              $format ne '' );
 136
 137     $self->request_format($format);
 138     my $ua = LWP::UserAgent->new(env_proxy => 1);
 139     $ua->agent(ref($self) ."/$MODVERSION");
 140     $self->ua($ua);
 141     $self->{'_authentication'} = [];
 142     return $self;
 143 }
 144
 145 # from Bio::DB::RandomAccessI
 146
 147 =head2 get_Seq_by_id
 148
 149  Title   : get_Seq_by_id
 150  Usage   : $seq = $db->get_Seq_by_id('ROA1_HUMAN')
 151  Function: Gets a Bio::Seq object by its name
 152  Returns : a Bio::Seq object
 153  Args    : the id (as a string) of a sequence
 154  Throws  : "id does not exist" exception
 155
 156
 157 =cut
 158
 159 sub get_Seq_by_id {
 160     my ($self,$seqid) = @_;
 161     $self->_sleep;
 162     my $seqio = $self->get_Stream_by_id([$seqid]);
 163     $self->throw("id does not exist") if( !defined $seqio ) ;
 164     if ($self->can('complexity') &&  defined $self->complexity && $self->complexity==0) {
 165         $self->warn("When complexity is set to 0, use get_Stream_by_id\n".
 166                     "Returning Bio::SeqIO object");
 167         return $seqio;
 168     }
 169     my @seqs;
 170     while( my $seq = $seqio->next_seq() ) { push @seqs, $seq; }
 171
 172     # Since $seqio will not be used anymore, explicitly close its filehandle
 173     # or it will cause trouble later on cleanup
 174     $seqio->close;
 175
 176     $self->throw("id '$seqid' does not exist") unless @seqs;
 177     if( wantarray ) { return @seqs } else { return shift @seqs }
 178 }
 179
 180 =head2 get_Seq_by_acc
 181
 182  Title   : get_Seq_by_acc
 183  Usage   : $seq = $db->get_Seq_by_acc('X77802');
 184  Function: Gets a Bio::Seq object by accession number
 185  Returns : A Bio::Seq object
 186  Args    : accession number (as a string)
 187  Throws  : "acc does not exist" exception
 188
 189 =cut
 190
 191 sub get_Seq_by_acc {
 192    my ($self,$seqid) = @_;
 193    $self->_sleep;
 194    my $seqio = $self->get_Stream_by_acc($seqid);
 195    $self->throw("acc '$seqid' does not exist") if( ! defined $seqio );
 196     if ($self->can('complexity') &&  defined $self->complexity && $self->complexity==0) {
 197         $self->warn("When complexity is set to 0, use get_Stream_by_acc\n".
 198                     "Returning Bio::SeqIO object");
 199         return $seqio;
 200     }
 201    my @seqs;
 202    while( my $seq = $seqio->next_seq() ) { push @seqs, $seq; }
 203    $self->throw("acc $seqid does not exist") unless @seqs;
 204    if( wantarray ) { return @seqs } else { return shift @seqs }
 205 }
 206
 207
 208 =head2 get_Seq_by_gi
 209
 210  Title   : get_Seq_by_gi
 211  Usage   : $seq = $db->get_Seq_by_gi('405830');
 212  Function: Gets a Bio::Seq object by gi number
 213  Returns : A Bio::Seq object
 214  Args    : gi number (as a string)
 215  Throws  : "gi does not exist" exception
 216
 217 =cut
 218
 219 sub get_Seq_by_gi {
 220    my ($self,$seqid) = @_;
 221     $self->_sleep;
 222    my $seqio = $self->get_Stream_by_gi($seqid);
 223    $self->throw("gi does not exist") if( !defined $seqio );
 224     if ($self->can('complexity') &&  defined $self->complexity && $self->complexity==0) {
 225         $self->warn("When complexity is set to 0, use get_Stream_by_gi\n".
 226                     "Returning Bio::SeqIO object");
 227         return $seqio;
 228     }
 229    my @seqs;
 230    while( my $seq = $seqio->next_seq() ) { push @seqs, $seq; }
 231    $self->throw("gi does not exist") unless @seqs;
 232    if( wantarray ) { return @seqs } else { return shift @seqs }
 233 }
 234
 235 =head2 get_Seq_by_version
 236
 237  Title   : get_Seq_by_version
 238  Usage   : $seq = $db->get_Seq_by_version('X77802.1');
 239  Function: Gets a Bio::Seq object by sequence version
 240  Returns : A Bio::Seq object
 241  Args    : accession.version (as a string)
 242  Throws  : "acc.version does not exist" exception
 243
 244 =cut
 245
 246 sub get_Seq_by_version {
 247    my ($self,$seqid) = @_;
 248     $self->_sleep;
 249    my $seqio = $self->get_Stream_by_version($seqid);
 250    $self->throw("accession.version does not exist") if( !defined $seqio );
 251     if ($self->can('complexity') &&  defined $self->complexity && $self->complexity==0) {
 252         $self->warn("When complexity is set to 0, use get_Stream_by_version\n".
 253                     "Returning Bio::SeqIO object");
 254         return $seqio;
 255     }
 256     my @seqs;
 257    while( my $seq = $seqio->next_seq() ) { push @seqs, $seq; }
 258    $self->throw("accession.version does not exist") unless @seqs;
 259    if( wantarray ) { return @seqs } else { return shift @seqs }
 260 }
 261
 262 # implementing class must define these
 263
 264 =head2 get_request
 265
 266  Title   : get_request
 267  Usage   : my $url = $self->get_request
 268  Function: returns a HTTP::Request object
 269  Returns :
 270  Args    : %qualifiers = a hash of qualifiers (ids, format, etc)
 271
 272 =cut
 273
 274 sub get_request {
 275     my ($self) = @_;
 276     my $msg = "Implementing class must define method get_request in class WebDBSeqI";
 277     $self->throw($msg);
 278 }
 279
 280 # class methods
 281
 282 =head2 get_Stream_by_id
 283
 284   Title   : get_Stream_by_id
 285   Usage   : $stream = $db->get_Stream_by_id( [$uid1, $uid2] );
 286   Function: Gets a series of Seq objects by unique identifiers
 287   Returns : a Bio::SeqIO stream object
 288   Args    : $ref : a reference to an array of unique identifiers for
 289                    the desired sequence entries
 290
 291
 292 =cut
 293
 294 sub get_Stream_by_id {
 295     my ($self, $ids) = @_;
 296     my ($webfmt,$localfmt) = $self->request_format;
 297     return $self->get_seq_stream('-uids' => $ids, '-mode' => 'single',
 298                                  '-format' => $webfmt);
 299 }
 300
 301 *get_Stream_by_batch = sub {
 302   my $self = shift;
 303   Carp::carp('get_Stream_by_batch() is deprecated; use get_Stream_by_id() instead');
 304   $self->get_Stream_by_id(@_)
 305 };
 306
 307
 308 =head2 get_Stream_by_acc
 309
 310   Title   : get_Stream_by_acc
 311   Usage   : $seq = $db->get_Stream_by_acc([$acc1, $acc2]);
 312   Function: Gets a series of Seq objects by accession numbers
 313   Returns : a Bio::SeqIO stream object
 314   Args    : $ref : a reference to an array of accession numbers for
 315                    the desired sequence entries
 316   Note    : For GenBank, this just calls the same code for get_Stream_by_id()
 317
 318 =cut
 319
 320 sub get_Stream_by_acc {
 321     my ($self, $ids ) = @_;
 322     return $self->get_seq_stream('-uids' => $ids, '-mode' => 'single');
 323 }
 324
 325
 326 =head2 get_Stream_by_gi
 327
 328   Title   : get_Stream_by_gi
 329   Usage   : $seq = $db->get_Stream_by_gi([$gi1, $gi2]);
 330   Function: Gets a series of Seq objects by gi numbers
 331   Returns : a Bio::SeqIO stream object
 332   Args    : $ref : a reference to an array of gi numbers for
 333                    the desired sequence entries
 334   Note    : For GenBank, this just calls the same code for get_Stream_by_id()
 335
 336 =cut
 337
 338 sub get_Stream_by_gi {
 339     my ($self, $ids ) = @_;
 340     return $self->get_seq_stream('-uids' => $ids, '-mode' => 'gi');
 341 }
 342
 343 =head2 get_Stream_by_version
 344
 345   Title   : get_Stream_by_version
 346   Usage   : $seq = $db->get_Stream_by_version([$version1, $version2]);
 347   Function: Gets a series of Seq objects by accession.versions
 348   Returns : a Bio::SeqIO stream object
 349   Args    : $ref : a reference to an array of accession.version strings for
 350                    the desired sequence entries
 351   Note    : For GenBank, this is implemented in NCBIHelper
 352
 353 =cut
 354
 355 sub get_Stream_by_version {
 356     my ($self, $ids ) = @_;
 357 #    $self->throw("Implementing class should define this method!");
 358     return $self->get_seq_stream('-uids' => $ids, '-mode' => 'version'); # how it should work
 359 }
 360
 361 =head2 get_Stream_by_query
 362
 363   Title   : get_Stream_by_query
 364   Usage   : $stream = $db->get_Stream_by_query($query);
 365   Function: Gets a series of Seq objects by way of a query string or oject
 366   Returns : a Bio::SeqIO stream object
 367   Args    : $query :   A string that uses the appropriate query language
 368             for the database or a Bio::DB::QueryI object.  It is suggested
 369             that you create the Bio::DB::Query object first and interrogate
 370             it for the entry count before you fetch a potentially large stream.
 371
 372 =cut
 373
 374 sub get_Stream_by_query {
 375     my ($self, $query ) = @_;
 376     return $self->get_seq_stream('-query' => $query, '-mode'=>'query');
 377 }
 378
 379 =head2 default_format
 380
 381  Title   : default_format
 382  Usage   : my $format = $self->default_format
 383  Function: Returns default sequence format for this module
 384  Returns : string
 385  Args    : none
 386
 387 =cut
 388
 389 sub default_format {
 390     return $DEFAULTFORMAT;
 391 }
 392
 393 # sorry, but this is hacked in because of BioFetch problems...
 394 sub db {
 395   my $self = shift;
 396   my $d    = $self->{_db};
 397   $self->{_db} = shift if @_;
 398   $d;
 399 }
 400
 401 =head2 request_format
 402
 403  Title   : request_format
 404  Usage   : my ($req_format, $ioformat) = $self->request_format;
 405            $self->request_format("genbank");
 406            $self->request_format("fasta");
 407  Function: Get/Set sequence format retrieval. The get-form will normally not
 408            be used outside of this and derived modules.
 409  Returns : Array of two strings, the first representing the format for
 410            retrieval, and the second specifying the corresponding SeqIO format.
 411  Args    : $format = sequence format
 412
 413 =cut
 414
 415 sub request_format {
 416     my ($self, $value) = @_;
 417
 418     if( defined $value ) {
 419         $self->{'_format'} = [ $value, $value];
 420     }
 421     return @{$self->{'_format'}};
 422 }
 423
 424 =head2 get_seq_stream
 425
 426  Title   : get_seq_stream
 427  Usage   : my $seqio = $self->get_seq_stream(%qualifiers)
 428  Function: builds a url and queries a web db
 429  Returns : a Bio::SeqIO stream capable of producing sequence
 430  Args    : %qualifiers = a hash qualifiers that the implementing class
 431            will process to make a url suitable for web querying
 432
 433 =cut
 434
 435 sub get_seq_stream {
 436         my ($self, %qualifiers) = @_;
 437         my ($rformat, $ioformat) = $self->request_format();
 438         my $seen = 0;
 439         foreach my $key ( keys %qualifiers ) {
 440                 if( $key =~ /format/i ) {
 441                         $rformat = $qualifiers{$key};
 442                         $seen = 1;
 443                 }
 444         }
 445         $qualifiers{'-format'} = $rformat if( !$seen);
 446         ($rformat, $ioformat) = $self->request_format($rformat);
 447         # These parameters are implemented for Bio::DB::GenBank objects only
 448         if($self->isa('Bio::DB::GenBank')) {
 449                 $self->seq_start() &&  ($qualifiers{'-seq_start'} = $self->seq_start());
 450                 $self->seq_stop() && ($qualifiers{'-seq_stop'} = $self->seq_stop());
 451                 $self->strand() && ($qualifiers{'-strand'} = $self->strand());
 452                 defined $self->complexity() && ($qualifiers{'-complexity'} = $self->complexity());
 453         }
 454         my $request = $self->get_request(%qualifiers);
 455         $request->proxy_authorization_basic($self->authentication)
 456             if ( $self->authentication);
 457         $self->debug("request is ". $request->as_string(). "\n");
 458
 459         # workaround for MSWin systems
 460         $self->retrieval_type('io_string') if $self->retrieval_type =~ /pipeline/ && $^O =~ /^MSWin/;
 461
 462         if ($self->retrieval_type =~ /pipeline/) {
 463                 # Try to create a stream using POSIX fork-and-pipe facility.
 464                 # this is a *big* win when fetching thousands of sequences from
 465                 # a web database because we can return the first entry while
 466                 # transmission is still in progress.
 467                 # Also, no need to keep sequence in memory or in a temporary file.
 468                 # If this fails (Windows, MacOS 9), we fall back to non-pipelined access.
 469
 470                 # fork and pipe: _stream_request()=><STREAM>
 471                 my ($result,$stream) = $self->_open_pipe();
 472
 473                 if (defined $result) {
 474                         $DB::fork_TTY = File::Spec->devnull; # prevents complaints from debugger
 475                         if (!$result) { # in child process
 476                             $self->_stream_request($request,$stream);
 477                             POSIX::_exit(0); #prevent END blocks from executing in this forked child
 478                         }
 479                         else {
 480                                 return Bio::SeqIO->new('-verbose' => $self->verbose,
 481                                                        '-format'  => $ioformat,
 482                                                        '-fh'      => $stream);
 483                         }
 484                 }
 485                 else {
 486                         $self->retrieval_type('io_string');
 487                 }
 488         }
 489
 490         if ($self->retrieval_type =~ /temp/i) {
 491                 my $dir = $self->io->tempdir( CLEANUP => 1);
 492                 my ( $fh, $tmpfile) = $self->io()->tempfile( DIR => $dir );
 493                 close $fh;
 494                 my $resp = $self->_request($request, $tmpfile);
 495                 if( ! -e $tmpfile || -z $tmpfile || ! $resp->is_success() ) {
 496                         $self->throw("WebDBSeqI Error - check query sequences!\n");
 497                 }
 498                 $self->postprocess_data('type' => 'file',
 499                                         'location' => $tmpfile);
 500                 # this may get reset when requesting batch mode
 501                 ($rformat,$ioformat) = $self->request_format();
 502                 if( $self->verbose > 0 ) {
 503                         open my $ERR, '<', $tmpfile or $self->throw("Could not read file '$tmpfile': $!");
 504                         while(<$ERR>) { $self->debug($_);}
 505                         close $ERR;
 506                 }
 507
 508                 return Bio::SeqIO->new('-verbose' => $self->verbose,
 509                                                                           '-format' => $ioformat,
 510                                                                           '-file'   => $tmpfile);
 511         }
 512
 513         if ($self->retrieval_type =~ /io_string/i ) {
 514                 my $resp = $self->_request($request);
 515                 my $content = $resp->content_ref;
 516                 $self->debug( "content is $$content\n");
 517                 if (!$resp->is_success() || length($$content) == 0) {
 518                         $self->throw("WebDBSeqI Error - check query sequences!\n");
 519                 }
 520                 ($rformat,$ioformat) = $self->request_format();
 521                 $self->postprocess_data('type'=> 'string',
 522                                         'location' => $content);
 523                 $self->debug( "str is $$content\n");
 524                 return Bio::SeqIO->new('-verbose' => $self->verbose,
 525                                        '-format' => $ioformat,
 526                                        '-fh'   => new IO::String($$content));
 527         }
 528
 529         # if we got here, we don't know how to handle the retrieval type
 530         $self->throw("retrieval type " . $self->retrieval_type .
 531                                          " unsupported\n");
 532 }
 533
 534 =head2 url_base_address
 535
 536  Title   : url_base_address
 537  Usage   : my $address = $self->url_base_address or
 538            $self->url_base_address($address)
 539  Function: Get/Set the base URL for the Web Database
 540  Returns : Base URL for the Web Database
 541  Args    : $address - URL for the WebDatabase
 542
 543 =cut
 544
 545 sub url_base_address {
 546     my $self = shift;
 547     my $d = $self->{'_baseaddress'};
 548     $self->{'_baseaddress'} = shift if @_;
 549     $d;
 550 }
 551
 552
 553 =head2 proxy
 554
 555  Title   : proxy
 556  Usage   : $httpproxy = $db->proxy('http')  or
 557            $db->proxy(['http','ftp'], 'http://myproxy' )
 558  Function: Get/Set a proxy for use of proxy
 559  Returns : a string indicating the proxy
 560  Args    : $protocol : an array ref of the protocol(s) to set/get
 561            $proxyurl : url of the proxy to use for the specified protocol
 562            $username : username (if proxy requires authentication)
 563            $password : password (if proxy requires authentication)
 564
 565 =cut
 566
 567 sub proxy {
 568     my ($self,$protocol,$proxy,$username,$password) = @_;
 569     return if ( !defined $self->ua || !defined $protocol
 570                       || !defined $proxy );
 571     $self->authentication($username, $password)
 572         if ($username && $password);
 573     return $self->ua->proxy($protocol,$proxy);
 574 }
 575
 576 =head2 authentication
 577
 578  Title   : authentication
 579  Usage   : $db->authentication($user,$pass)
 580  Function: Get/Set authentication credentials
 581  Returns : Array of user/pass
 582  Args    : Array or user/pass
 583
 584
 585 =cut
 586
 587 sub authentication{
 588    my ($self,$u,$p) = @_;
 589
 590    if( defined $u && defined $p ) {
 591        $self->{'_authentication'} = [ $u,$p];
 592    }
 593    return @{$self->{'_authentication'}};
 594 }
 595
 596
 597 =head2 retrieval_type
 598
 599  Title   : retrieval_type
 600  Usage   : $self->retrieval_type($type);
 601            my $type = $self->retrieval_type
 602  Function: Get/Set a proxy for retrieval_type (pipeline, io_string or tempfile)
 603  Returns : string representing retrieval type
 604  Args    : $value - the value to store
 605
 606 This setting affects how the data stream from the remote web server is
 607 processed and passed to the Bio::SeqIO layer. Three types of retrieval
 608 types are currently allowed:
 609
 610    pipeline  Perform a fork in an attempt to begin streaming
 611              while the data is still downloading from the remote
 612              server.  Disk, memory and speed efficient, but will
 613              not work on Windows or MacOS 9 platforms.
 614
 615    io_string Store downloaded database entry(s) in memory.  Can be
 616              problematic for batch downloads because entire set
 617              of entries must fit in memory.  Alll entries must be
 618              downloaded before processing can begin.
 619
 620    tempfile  Store downloaded database entry(s) in a temporary file.
 621              All entries must be downloaded before processing can
 622              begin.
 623
 624 The default is pipeline, with automatic fallback to io_string if
 625 pipelining is not available.
 626
 627 =cut
 628
 629 sub retrieval_type {
 630     my ($self, $value) = @_;
 631     if( defined $value ) {
 632         $value = lc $value;
 633         if( ! $RETRIEVAL_TYPES{$value} ) {
 634             $self->warn("invalid retrieval type $value must be one of (" .
 635                         join(",", keys %RETRIEVAL_TYPES), ")");
 636             $value = $DEFAULT_RETRIEVAL_TYPE;
 637         }
 638         $self->{'_retrieval_type'} = $value;
 639     }
 640     return $self->{'_retrieval_type'};
 641 }
 642
 643 =head2 url_params
 644
 645  Title   : url_params
 646  Usage   : my $params = $self->url_params or
 647            $self->url_params($params)
 648  Function: Get/Set the URL parameters for the Web Database
 649  Returns : url parameters for Web Database
 650  Args    : $params - parameters to be appended to the URL for the WebDatabase
 651
 652 =cut
 653
 654 sub url_params {
 655         my ($self, $value) = @_;
 656         if( defined $value ) {
 657                 $self->{'_urlparams'} = $value;
 658         }
 659 }
 660
 661 =head2 ua
 662
 663  Title   : ua
 664  Usage   : my $ua = $self->ua or
 665            $self->ua($ua)
 666  Function: Get/Set a LWP::UserAgent for use
 667  Returns : reference to LWP::UserAgent Object
 668  Args    : $ua - must be a LWP::UserAgent
 669
 670 =cut
 671
 672 sub ua {
 673         my ($self, $ua) = @_;
 674         if( defined $ua && $ua->isa("LWP::UserAgent") ) {
 675                 $self->{'_ua'} = $ua;
 676         }
 677         return $self->{'_ua'};
 678 }
 679
 680 =head2 postprocess_data
 681
 682  Title   : postprocess_data
 683  Usage   : $self->postprocess_data ( 'type' => 'string',
 684                                      'location' => \$datastr);
 685  Function: process downloaded data before loading into a Bio::SeqIO
 686  Returns : void
 687  Args    : hash with two keys - 'type' can be 'string' or 'file'
 688                               - 'location' either file location or string
 689                                            reference containing data
 690
 691 =cut
 692
 693 sub postprocess_data {
 694         my ( $self, %args) = @_;
 695         return;
 696 }
 697
 698 # private methods
 699 sub _request {
 700         my ($self, $url,$tmpfile) = @_;
 701         my ($resp);
 702         if( defined $tmpfile && $tmpfile ne '' ) {
 703                 $resp =  $self->ua->request($url, $tmpfile);
 704         } else {
 705                 $resp =  $self->ua->request($url);
 706         }
 707
 708         if( $resp->is_error  ) {
 709                 $self->throw("WebDBSeqI Request Error:\n".$resp->as_string);
 710         }
 711         return $resp;
 712 }
 713
 714 #mod_perl-safe replacement for the open(BLEH,'-|') call.  if running
 715 #under mod_perl, detects it and closes the child's STDIN and STDOUT
 716 #handles
 717 sub _open_pipe {
 718   my ($self) = @_;
 719   # is mod_perl running?  Which API?
 720   my $mp = $self->mod_perl_api;
 721   if($mp and ! our $loaded_apache_sp) {
 722     my $load_api = ($mp == 1) ? 'use Apache::SubProcess': 'use Apache2::SubProcess';
 723     eval $load_api;
 724     $@ and $self->throw("$@\n$load_api module required for running under mod_perl");
 725     $loaded_apache_sp = 1;
 726   }
 727
 728   my $pipe = IO::Pipe->new();
 729
 730   local $SIG{CHLD} = 'IGNORE';
 731   defined(my $pid = fork)
 732     or $self->throw("Couldn't fork: $!");
 733
 734   unless($pid) {
 735     #CHILD
 736     $pipe->writer();
 737
 738     #if we're running under mod_perl, clean up some things after this fork
 739     if ($ENV{MOD_PERL} and my $r = eval{Apache->request} ) {
 740       $r->cleanup_for_exec;
 741       #don't read or write the mod_perl parent's tied filehandles
 742       close STDIN; close STDOUT;
 743       setsid() or $self->throw('Could not detach from parent');
 744     }
 745   } else {
 746     #PARENT
 747     $pipe->reader();
 748   }
 749   return ( $pid, $pipe );
 750 }
 751
 752 # send web request to specified filehandle, or stdout, for streaming purposes
 753 sub _stream_request {
 754   my $self    = shift;
 755   my $request = shift;
 756   my $dest_fh = shift || \*STDOUT;
 757
 758   # fork so as to pipe output of fetch process through to
 759   # postprocess_data method call.
 760   my ($child,$fetch) = $self->_open_pipe();
 761
 762   if ($child) {
 763     #PARENT
 764     local ($/) = "//\n";  # assume genbank/swiss format
 765     $| = 1;
 766     my $records = 0;
 767     while (my $record = <$fetch>) {
 768       $records++;
 769       $self->postprocess_data('type'     => 'string',
 770                               'location' => \$record);
 771       print $dest_fh $record;
 772     }
 773     $/ = "\n"; # reset to be safe;
 774     close $dest_fh; #must explicitly close here, because the hard
 775                     #exits don't cloes them for us
 776   }
 777   else {
 778     #CHILD
 779     $| = 1;
 780     my $resp =  $self->ua->request($request,
 781                                    sub { print $fetch $_[0] }
 782                                    );
 783     if( $resp->is_error  ) {
 784       $self->throw("WebDBSeqI Request Error:\n".$resp->as_string);
 785     }
 786     close $fetch; #must explicitly close here, because the hard exists
 787                   #don't close them for us
 788     POSIX::_exit(0);
 789   }
 790 }
 791
 792 sub io {
 793     my ($self,$io) = @_;
 794
 795     if(defined($io) || (! exists($self->{'_io'}))) {
 796         $io = Bio::Root::IO->new() unless $io;
 797         $self->{'_io'} = $io;
 798     }
 799     return $self->{'_io'};
 800 }
 801
 802
 803 =head2 delay
 804
 805  Title   : delay
 806  Usage   : $secs = $self->delay([$secs])
 807  Function: get/set number of seconds to delay between fetches
 808  Returns : number of seconds to delay
 809  Args    : new value
 810
 811 NOTE: the default is to use the value specified by delay_policy().
 812 This can be overridden by calling this method, or by passing the
 813 -delay argument to new().
 814
 815 =cut
 816
 817 sub delay {
 818    my $self = shift;
 819    my $d = $self->{'_delay'};
 820    $self->{'_delay'} = shift if @_;
 821    $d;
 822 }
 823
 824 =head2 delay_policy
 825
 826  Title   : delay_policy
 827  Usage   : $secs = $self->delay_policy
 828  Function: return number of seconds to delay between calls to remote db
 829  Returns : number of seconds to delay
 830  Args    : none
 831
 832 NOTE: The default delay policy is 0s.  Override in subclasses to
 833 implement delays.  The timer has only second resolution, so the delay
 834 will actually be +/- 1s.
 835
 836 =cut
 837
 838 sub delay_policy {
 839    my $self = shift;
 840    return 0;
 841 }
 842
 843 =head2 _sleep
 844
 845  Title   : _sleep
 846  Usage   : $self->_sleep
 847  Function: sleep for a number of seconds indicated by the delay policy
 848  Returns : none
 849  Args    : none
 850
 851 NOTE: This method keeps track of the last time it was called and only
 852 imposes a sleep if it was called more recently than the delay_policy()
 853 allows.
 854
 855 =cut
 856
 857 sub _sleep {
 858    my $self = shift;
 859    my $last_invocation = $LAST_INVOCATION_TIME;
 860    if (time - $LAST_INVOCATION_TIME < $self->delay) {
 861       my $delay = $self->delay - (time - $LAST_INVOCATION_TIME);
 862       warn "sleeping for $delay seconds\n" if $self->verbose > 0;
 863       sleep $delay;
 864    }
 865    $LAST_INVOCATION_TIME = time;
 866 }
 867
 868 =head2 mod_perl_api
 869
 870  Title   : mod_perl_api
 871  Usage   : $version = self->mod_perl_api
 872  Function: Returns API version of mod_perl being used based on set env. variables
 873  Returns : mod_perl API version; if mod_perl isn't loaded, returns 0
 874  Args    : none
 875
 876 =cut
 877
 878 sub mod_perl_api {
 879     my $self = shift;
 880     my $v = $ENV{MOD_PERL} ?
 881             ( exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} >= 2 ) ?
 882             2 :
 883             1
 884         : 0;
 885     return $v;
 886 }
 887
 888 1;