source: main/trunk/greenstone2/perllib/cpan/LWP/Protocol/http.pm@ 27174

Last change on this file since 27174 was 27174, checked in by davidb, 11 years ago

Perl modules from CPAN that are used in supporting activate.pl, but not part of the Perl core. Only PMs included.

File size: 12.5 KB
Line 
1package LWP::Protocol::http;
2
3use strict;
4
5require HTTP::Response;
6require HTTP::Status;
7require Net::HTTP;
8
9use vars qw(@ISA @EXTRA_SOCK_OPTS);
10
11require LWP::Protocol;
12@ISA = qw(LWP::Protocol);
13
14my $CRLF = "\015\012";
15
16sub _new_socket
17{
18 my($self, $host, $port, $timeout) = @_;
19 my $conn_cache = $self->{ua}{conn_cache};
20 if ($conn_cache) {
21 if (my $sock = $conn_cache->withdraw($self->socket_type, "$host:$port")) {
22 return $sock if $sock && !$sock->can_read(0);
23 # if the socket is readable, then either the peer has closed the
24 # connection or there are some garbage bytes on it. In either
25 # case we abandon it.
26 $sock->close;
27 }
28 }
29
30 local($^W) = 0; # IO::Socket::INET can be noisy
31 my $sock = $self->socket_class->new(PeerAddr => $host,
32 PeerPort => $port,
33 LocalAddr => $self->{ua}{local_address},
34 Proto => 'tcp',
35 Timeout => $timeout,
36 KeepAlive => !!$conn_cache,
37 SendTE => 1,
38 $self->_extra_sock_opts($host, $port),
39 );
40
41 unless ($sock) {
42 # IO::Socket::INET leaves additional error messages in $@
43 my $status = "Can't connect to $host:$port";
44 if ($@ =~ /\bconnect: (.*)/ ||
45 $@ =~ /\b(Bad hostname)\b/ ||
46 $@ =~ /\b(certificate verify failed)\b/ ||
47 $@ =~ /\b(Crypt-SSLeay can't verify hostnames)\b/
48 ) {
49 $status .= " ($1)";
50 }
51 die "$status\n\n$@";
52 }
53
54 # perl 5.005's IO::Socket does not have the blocking method.
55 eval { $sock->blocking(0); };
56
57 $sock;
58}
59
60sub socket_type
61{
62 return "http";
63}
64
65sub socket_class
66{
67 my $self = shift;
68 (ref($self) || $self) . "::Socket";
69}
70
71sub _extra_sock_opts # to be overridden by subclass
72{
73 return @EXTRA_SOCK_OPTS;
74}
75
76sub _check_sock
77{
78 #my($self, $req, $sock) = @_;
79}
80
81sub _get_sock_info
82{
83 my($self, $res, $sock) = @_;
84 if (defined(my $peerhost = $sock->peerhost)) {
85 $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
86 }
87}
88
89sub _fixup_header
90{
91 my($self, $h, $url, $proxy) = @_;
92
93 # Extract 'Host' header
94 my $hhost = $url->authority;
95 if ($hhost =~ s/^([^\@]*)\@//) { # get rid of potential "user:pass@"
96 # add authorization header if we need them. HTTP URLs do
97 # not really support specification of user and password, but
98 # we allow it.
99 if (defined($1) && not $h->header('Authorization')) {
100 require URI::Escape;
101 $h->authorization_basic(map URI::Escape::uri_unescape($_),
102 split(":", $1, 2));
103 }
104 }
105 $h->init_header('Host' => $hhost);
106
107 if ($proxy) {
108 # Check the proxy URI's userinfo() for proxy credentials
109 # export http_proxy="http://proxyuser:proxypass@proxyhost:port"
110 my $p_auth = $proxy->userinfo();
111 if(defined $p_auth) {
112 require URI::Escape;
113 $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
114 split(":", $p_auth, 2))
115 }
116 }
117}
118
119sub hlist_remove {
120 my($hlist, $k) = @_;
121 $k = lc $k;
122 for (my $i = @$hlist - 2; $i >= 0; $i -= 2) {
123 next unless lc($hlist->[$i]) eq $k;
124 splice(@$hlist, $i, 2);
125 }
126}
127
128sub request
129{
130 my($self, $request, $proxy, $arg, $size, $timeout) = @_;
131
132 $size ||= 4096;
133
134 # check method
135 my $method = $request->method;
136 unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token
137 return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
138 'Library does not allow method ' .
139 "$method for 'http:' URLs");
140 }
141
142 my $url = $request->uri;
143 my($host, $port, $fullpath);
144
145 # Check if we're proxy'ing
146 if (defined $proxy) {
147 # $proxy is an URL to an HTTP server which will proxy this request
148 $host = $proxy->host;
149 $port = $proxy->port;
150 $fullpath = $method eq "CONNECT" ?
151 ($url->host . ":" . $url->port) :
152 $url->as_string;
153 }
154 else {
155 $host = $url->host;
156 $port = $url->port;
157 $fullpath = $url->path_query;
158 $fullpath = "/$fullpath" unless $fullpath =~ m,^/,;
159 }
160
161 # connect to remote site
162 my $socket = $self->_new_socket($host, $port, $timeout);
163
164 my $http_version = "";
165 if (my $proto = $request->protocol) {
166 if ($proto =~ /^(?:HTTP\/)?(1.\d+)$/) {
167 $http_version = $1;
168 $socket->http_version($http_version);
169 $socket->send_te(0) if $http_version eq "1.0";
170 }
171 }
172
173 $self->_check_sock($request, $socket);
174
175 my @h;
176 my $request_headers = $request->headers->clone;
177 $self->_fixup_header($request_headers, $url, $proxy);
178
179 $request_headers->scan(sub {
180 my($k, $v) = @_;
181 $k =~ s/^://;
182 $v =~ s/\n/ /g;
183 push(@h, $k, $v);
184 });
185
186 my $content_ref = $request->content_ref;
187 $content_ref = $$content_ref if ref($$content_ref);
188 my $chunked;
189 my $has_content;
190
191 if (ref($content_ref) eq 'CODE') {
192 my $clen = $request_headers->header('Content-Length');
193 $has_content++ if $clen;
194 unless (defined $clen) {
195 push(@h, "Transfer-Encoding" => "chunked");
196 $has_content++;
197 $chunked++;
198 }
199 }
200 else {
201 # Set (or override) Content-Length header
202 my $clen = $request_headers->header('Content-Length');
203 if (defined($$content_ref) && length($$content_ref)) {
204 $has_content = length($$content_ref);
205 if (!defined($clen) || $clen ne $has_content) {
206 if (defined $clen) {
207 warn "Content-Length header value was wrong, fixed";
208 hlist_remove(\@h, 'Content-Length');
209 }
210 push(@h, 'Content-Length' => $has_content);
211 }
212 }
213 elsif ($clen) {
214 warn "Content-Length set when there is no content, fixed";
215 hlist_remove(\@h, 'Content-Length');
216 }
217 }
218
219 my $write_wait = 0;
220 $write_wait = 2
221 if ($request_headers->header("Expect") || "") =~ /100-continue/;
222
223 my $req_buf = $socket->format_request($method, $fullpath, @h);
224 #print "------\n$req_buf\n------\n";
225
226 if (!$has_content || $write_wait || $has_content > 8*1024) {
227 WRITE:
228 {
229 # Since this just writes out the header block it should almost
230 # always succeed to send the whole buffer in a single write call.
231 my $n = $socket->syswrite($req_buf, length($req_buf));
232 unless (defined $n) {
233 redo WRITE if $!{EINTR};
234 if ($!{EAGAIN}) {
235 select(undef, undef, undef, 0.1);
236 redo WRITE;
237 }
238 die "write failed: $!";
239 }
240 if ($n) {
241 substr($req_buf, 0, $n, "");
242 }
243 else {
244 select(undef, undef, undef, 0.5);
245 }
246 redo WRITE if length $req_buf;
247 }
248 }
249
250 my($code, $mess, @junk);
251 my $drop_connection;
252
253 if ($has_content) {
254 my $eof;
255 my $wbuf;
256 my $woffset = 0;
257 INITIAL_READ:
258 if ($write_wait) {
259 # skip filling $wbuf when waiting for 100-continue
260 # because if the response is a redirect or auth required
261 # the request will be cloned and there is no way
262 # to reset the input stream
263 # return here via the label after the 100-continue is read
264 }
265 elsif (ref($content_ref) eq 'CODE') {
266 my $buf = &$content_ref();
267 $buf = "" unless defined($buf);
268 $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
269 if $chunked;
270 substr($buf, 0, 0) = $req_buf if $req_buf;
271 $wbuf = \$buf;
272 }
273 else {
274 if ($req_buf) {
275 my $buf = $req_buf . $$content_ref;
276 $wbuf = \$buf;
277 }
278 else {
279 $wbuf = $content_ref;
280 }
281 $eof = 1;
282 }
283
284 my $fbits = '';
285 vec($fbits, fileno($socket), 1) = 1;
286
287 WRITE:
288 while ($write_wait || $woffset < length($$wbuf)) {
289
290 my $sel_timeout = $timeout;
291 if ($write_wait) {
292 $sel_timeout = $write_wait if $write_wait < $sel_timeout;
293 }
294 my $time_before;
295 $time_before = time if $sel_timeout;
296
297 my $rbits = $fbits;
298 my $wbits = $write_wait ? undef : $fbits;
299 my $sel_timeout_before = $sel_timeout;
300 SELECT:
301 {
302 my $nfound = select($rbits, $wbits, undef, $sel_timeout);
303 if ($nfound < 0) {
304 if ($!{EINTR} || $!{EAGAIN}) {
305 if ($time_before) {
306 $sel_timeout = $sel_timeout_before - (time - $time_before);
307 $sel_timeout = 0 if $sel_timeout < 0;
308 }
309 redo SELECT;
310 }
311 die "select failed: $!";
312 }
313 }
314
315 if ($write_wait) {
316 $write_wait -= time - $time_before;
317 $write_wait = 0 if $write_wait < 0;
318 }
319
320 if (defined($rbits) && $rbits =~ /[^\0]/) {
321 # readable
322 my $buf = $socket->_rbuf;
323 my $n = $socket->sysread($buf, 1024, length($buf));
324 unless (defined $n) {
325 die "read failed: $!" unless $!{EINTR} || $!{EAGAIN};
326 # if we get here the rest of the block will do nothing
327 # and we will retry the read on the next round
328 }
329 elsif ($n == 0) {
330 # the server closed the connection before we finished
331 # writing all the request content. No need to write any more.
332 $drop_connection++;
333 last WRITE;
334 }
335 $socket->_rbuf($buf);
336 if (!$code && $buf =~ /\015?\012\015?\012/) {
337 # a whole response header is present, so we can read it without blocking
338 ($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
339 junk_out => \@junk,
340 );
341 if ($code eq "100") {
342 $write_wait = 0;
343 undef($code);
344 goto INITIAL_READ;
345 }
346 else {
347 $drop_connection++;
348 last WRITE;
349 # XXX should perhaps try to abort write in a nice way too
350 }
351 }
352 }
353 if (defined($wbits) && $wbits =~ /[^\0]/) {
354 my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
355 unless (defined $n) {
356 die "write failed: $!" unless $!{EINTR} || $!{EAGAIN};
357 $n = 0; # will retry write on the next round
358 }
359 elsif ($n == 0) {
360 die "write failed: no bytes written";
361 }
362 $woffset += $n;
363
364 if (!$eof && $woffset >= length($$wbuf)) {
365 # need to refill buffer from $content_ref code
366 my $buf = &$content_ref();
367 $buf = "" unless defined($buf);
368 $eof++ unless length($buf);
369 $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
370 if $chunked;
371 $wbuf = \$buf;
372 $woffset = 0;
373 }
374 }
375 } # WRITE
376 }
377
378 ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
379 unless $code;
380 ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
381 if $code eq "100";
382
383 my $response = HTTP::Response->new($code, $mess);
384 my $peer_http_version = $socket->peer_http_version;
385 $response->protocol("HTTP/$peer_http_version");
386 {
387 local $HTTP::Headers::TRANSLATE_UNDERSCORE;
388 $response->push_header(@h);
389 }
390 $response->push_header("Client-Junk" => \@junk) if @junk;
391
392 $response->request($request);
393 $self->_get_sock_info($response, $socket);
394
395 if ($method eq "CONNECT") {
396 $response->{client_socket} = $socket; # so it can be picked up
397 return $response;
398 }
399
400 if (my @te = $response->remove_header('Transfer-Encoding')) {
401 $response->push_header('Client-Transfer-Encoding', \@te);
402 }
403 $response->push_header('Client-Response-Num', scalar $socket->increment_response_count);
404
405 my $complete;
406 $response = $self->collect($arg, $response, sub {
407 my $buf = ""; #prevent use of uninitialized value in SSLeay.xs
408 my $n;
409 READ:
410 {
411 $n = $socket->read_entity_body($buf, $size);
412 unless (defined $n) {
413 redo READ if $!{EINTR} || $!{EAGAIN};
414 die "read failed: $!";
415 }
416 redo READ if $n == -1;
417 }
418 $complete++ if !$n;
419 return \$buf;
420 } );
421 $drop_connection++ unless $complete;
422
423 @h = $socket->get_trailers;
424 if (@h) {
425 local $HTTP::Headers::TRANSLATE_UNDERSCORE;
426 $response->push_header(@h);
427 }
428
429 # keep-alive support
430 unless ($drop_connection) {
431 if (my $conn_cache = $self->{ua}{conn_cache}) {
432 my %connection = map { (lc($_) => 1) }
433 split(/\s*,\s*/, ($response->header("Connection") || ""));
434 if (($peer_http_version eq "1.1" && !$connection{close}) ||
435 $connection{"keep-alive"})
436 {
437 $conn_cache->deposit($self->socket_type, "$host:$port", $socket);
438 }
439 }
440 }
441
442 $response;
443}
444
445
446#-----------------------------------------------------------
447package LWP::Protocol::http::SocketMethods;
448
449sub ping {
450 my $self = shift;
451 !$self->can_read(0);
452}
453
454sub increment_response_count {
455 my $self = shift;
456 return ++${*$self}{'myhttp_response_count'};
457}
458
459#-----------------------------------------------------------
460package LWP::Protocol::http::Socket;
461use vars qw(@ISA);
462@ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP);
463
4641;
Note: See TracBrowser for help on using the repository browser.