← Back to branch summary

~ubuntu-branches/ubuntu/raring/bioperl/raring

« back to all changes in this revision

Viewing changes to Bio/Root/HTTPget.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2008-03-18 14:44:57 UTC
  • mfrom: (4 hardy)
  • mto: This revision was merged to the branch mainline in revision 6.
  • Revision ID: james.westby@ubuntu.com-20080318144457-1jjoztrvqwf0gruk
http://bugs.debian.org/448890
* debian/control:
  - Removed MIA Matt Hope (dopey) from the Uploaders field.
    Thank you for your work, Matt. I hope you are doing well.
  - Downgraded some recommended package to the 'Suggests' priority,
    according to the following discussion on Upstream's mail list.
    http://bioperl.org/pipermail/bioperl-l/2008-March/027379.html
    (Closes: #448890)
* debian/copyright converted to machine-readable format.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/Root/HTTPget.pm
1
 
# $Id: HTTPget.pm,v 1.7 2003/07/26 18:07:06 heikki Exp $
 
1
# $Id: HTTPget.pm,v 1.14.4.1 2006/10/02 23:10:23 sendu Exp $
2
2
#
3
3
# BioPerl module for fallback HTTP get operations.
4
4
# Module is proxy-aware 
32
32
 
33
33
 $response    = $web->get('http://localhost/images/navauthors.gif');
34
34
 $response    = $web->get(-url=>'http://www.google.com',
35
 
                    -proxy=>'http://www.modperl.com');
 
35
                                    -proxy=>'http://www.modperl.com');
36
36
 
37
37
=head1 DESCRIPTION
38
38
 
54
54
 
55
55
User feedback is an integral part of the evolution of this
56
56
and other Bioperl modules. Send your comments and suggestions preferably
57
 
 to one of the Bioperl mailing lists.
 
57
to one of the Bioperl mailing lists.
58
58
Your participation is much appreciated.
59
59
 
60
 
  bioperl-l@bioperl.org                 - General discussion
61
 
  http://bio.perl.org/MailList.html     - About the mailing lists
 
60
  bioperl-l@bioperl.org                  - General discussion
 
61
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
62
62
 
63
 
=head2 Reporting Bugs
 
63
 =head2 Reporting Bugs
64
64
 
65
65
Report bugs to the Bioperl bug tracking system to help us keep track
66
 
the bugs and their resolution.  Bug reports can be submitted via email
67
 
or the web:
 
66
the bugs and their resolution.  Bug reports can be submitted via the
 
67
web:
68
68
 
69
 
  bioperl-bugs@bio.perl.org
70
 
  http://bugzilla.bioperl.org/
 
69
  http://bugzilla.open-bio.org/
71
70
 
72
71
=head1 AUTHOR - Lincoln Stein
73
72
 
86
85
package Bio::Root::HTTPget;
87
86
 
88
87
use strict;
89
 
use Bio::Root::Root;
90
88
use IO::Socket qw(:DEFAULT :crlf);
91
 
use vars '@ISA';
92
89
 
93
 
@ISA = qw(Bio::Root::Root);
 
90
use base qw(Bio::Root::Root);
94
91
 
95
92
 
96
93
=head2 get
99
96
 Usage   : my $resp = get(-url => $url);
100
97
 Function: 
101
98
 Returns : string
102
 
 Args    : -url   => URL to HTTPGet
103
 
           -proxy => proxy to use
104
 
           -user  => username for proxy or authentication
105
 
           -pass  => password for proxy or authentication
 
99
 Args    : -url     => URL to HTTPGet
 
100
           -proxy   => proxy to use
 
101
           -user    => username for proxy or authentication
 
102
           -pass    => password for proxy or authentication
 
103
           -timeout => timeout
106
104
 
107
105
=cut
108
106
 
111
109
    if( ref($_[0]) ) {
112
110
        $self = shift;
113
111
    }
114
 
 
 
112
    
115
113
    my ($url,$proxy,$timeout,$auth_user,$auth_pass) = 
116
114
        __PACKAGE__->_rearrange([qw(URL PROXY TIMEOUT USER PASS)],@_);
117
115
    my $dest  = $proxy || $url;
120
118
        = _http_parse_url($dest) or __PACKAGE__->throw("invalid URL $url");
121
119
    $auth_user ||= $user;
122
120
    $auth_pass ||= $pass;
123
 
    if( $self ) { 
124
 
        unless( $auth_user ) { 
125
 
            ($auth_user,$auth_pass) = $self->authentication;
126
 
        }
127
 
        unless( $proxy ) { $proxy = $self->proxy() }
 
121
    if ($self) {
 
122
        unless ($proxy) {
 
123
            $proxy = $self->proxy;
 
124
        }
 
125
        unless ($auth_user) { 
 
126
            ($auth_user, $auth_pass) = $self->authentication;
 
127
        }
128
128
    }
129
129
    $path = $url if $proxy;
 
130
    
130
131
    # set up the connection
131
132
    my $socket = _http_connect($host,$port) or __PACKAGE__->throw("can't connect: $@");
132
133
 
157
158
    if ($stat_code == 302 || $stat_code == 301) { # redirect
158
159
        my $location = $headers{Location} or 
159
160
            __PACKAGE__->throw("invalid redirect: no Location header");
160
 
        return get($location,$proxy,$timeout); # recursive call
 
161
        return get(-url => $location, -proxy => $proxy, -timeout => $timeout, -user => $auth_user, -pass => $auth_pass); # recursive call
161
162
    }
162
163
 
163
164
    elsif ($stat_code == 401) { # auth required
233
234
  if ($stat_code == 302 || $stat_code == 301) {  # redirect
234
235
    my $location = $headers{Location} or 
235
236
        __PACKAGE__->throw("invalid redirect: no Location header");
236
 
    return get($location,$proxy,$timeout);  # recursive call
 
237
    return getFH(-url => $location, -proxy => $proxy, -timeout => $timeout, -user => $auth_user, -pass => $auth_pass);  # recursive call
237
238
  }
238
239
 
239
240
  elsif ($stat_code == 401) { # auth required
336
337
 Title   : proxy
337
338
 Usage   : $httpproxy = $db->proxy('http')  or 
338
339
           $db->proxy(['http','ftp'], 'http://myproxy' )
339
 
 Function: Get/Set a proxy for use of proxy
 
340
 Function: Get/Set a proxy for use of proxy. Defaults to environment variable
 
341
           http_proxy if present.
340
342
 Returns : a string indicating the proxy
341
343
 Args    : $protocol : an array ref of the protocol(s) to set/get
342
344
           $proxyurl : url of the proxy to use for the specified protocol
348
350
sub proxy {
349
351
    my ($self,$protocol,$proxy,$username,$password) = @_;
350
352
    $protocol ||= 'http';
351
 
    return undef unless (  defined $protocol && defined $proxy );
 
353
    unless ($proxy) {
 
354
        if (defined $ENV{http_proxy}) {
 
355
            $proxy = $ENV{http_proxy};
 
356
            if ($proxy =~ /\@/) {
 
357
                ($username, $password, $proxy) = $proxy =~ m{http://(\S+):(\S+)\@(\S+)};
 
358
                $proxy = 'http://'.$proxy;
 
359
            }
 
360
        }
 
361
    }
 
362
    return unless (defined $proxy);
352
363
    $self->authentication($username, $password) 
353
364
        if ($username && $password);
354
365
    return $self->{'_proxy'}->{$protocol} = $proxy;