ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-HTTP/HTTP.pm
(Generate patch)

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.42 by root, Mon Jul 6 00:08:16 2009 UTC vs.
Revision 1.56 by root, Mon Sep 6 05:30:54 2010 UTC

… …
41use strict; 41use strict;
42no warnings; 42no warnings;
43 43
44use Errno (); 44use Errno ();
45 45
46use AnyEvent 4.452 (); 46use AnyEvent 5.0 ();
47use AnyEvent::Util (); 47use AnyEvent::Util ();
48use AnyEvent::Socket (); 48use AnyEvent::Socket ();
49use AnyEvent::Handle (); 49use AnyEvent::Handle ();
50 50
51use base Exporter::; 51use base Exporter::;
52 52
53our $VERSION = '1.12'; 53our $VERSION = '1.45';
54 54
55our @EXPORT = qw(http_get http_post http_head http_request); 55our @EXPORT = qw(http_get http_post http_head http_request);
56 56
57our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 57our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
58our $MAX_RECURSE = 10; 58our $MAX_RECURSE = 10;
59our $MAX_PERSISTENT = 8; 59our $MAX_PERSISTENT = 8;
60our $PERSISTENT_TIMEOUT = 2; 60our $PERSISTENT_TIMEOUT = 2;
61our $TIMEOUT = 300; 61our $TIMEOUT = 300;
62 62
63# changing these is evil 63# changing these is evil
64our $MAX_PERSISTENT_PER_HOST = 2; 64our $MAX_PERSISTENT_PER_HOST = 0;
65our $MAX_PER_HOST = 4; 65our $MAX_PER_HOST = 4;
66 66
67our $PROXY; 67our $PROXY;
68our $ACTIVE = 0; 68our $ACTIVE = 0;
69 69
… …
99The callback will be called with the response body data as first argument 99The callback will be called with the response body data as first argument
100(or C<undef> if an error occured), and a hash-ref with response headers as 100(or C<undef> if an error occured), and a hash-ref with response headers as
101second argument. 101second argument.
102 102
103All the headers in that hash are lowercased. In addition to the response 103All the headers in that hash are lowercased. In addition to the response
104headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason> 104headers, the "pseudo-headers" (uppercase to avoid clashing with possible
105response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
105contain the three parts of the HTTP Status-Line of the same name. The 106three parts of the HTTP Status-Line of the same name.
107
106pseudo-header C<URL> contains the original URL (which can differ from the 108The pseudo-header C<URL> contains the actual URL (which can differ from
107requested URL when following redirects). 109the requested URL when following redirects - for example, you might get
110an error that your URL scheme is not supported even though your URL is a
111valid http URL because it redirected to an ftp URL, in which case you can
112look at the URL pseudo header).
113
114The pseudo-header C<Redirect> only exists when the request was a result
115of an internal redirect. In that case it is an array reference with
116the C<($data, $headers)> from the redirect response. Note that this
117response could in turn be the result of a redirect itself, and C<<
118$headers->{Redirect}[1]{Redirect} >> will then contain the original
119response, and so on.
108 120
109If the server sends a header multiple times, then their contents will be 121If the server sends a header multiple times, then their contents will be
110joined together with a comma (C<,>), as per the HTTP spec. 122joined together with a comma (C<,>), as per the HTTP spec.
111 123
112If an internal error occurs, such as not being able to resolve a hostname, 124If an internal error occurs, such as not being able to resolve a hostname,
… …
138 150
139=item headers => hashref 151=item headers => hashref
140 152
141The request headers to use. Currently, C<http_request> may provide its 153The request headers to use. Currently, C<http_request> may provide its
142own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers 154own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
143and will provide defaults for C<User-Agent:> and C<Referer:>. 155and will provide defaults for C<User-Agent:> and C<Referer:> (this can be
156suppressed by using C<undef> for these headers in which case they won't be
157sent at all).
144 158
145=item timeout => $seconds 159=item timeout => $seconds
146 160
147The time-out to use for various stages - each connect attempt will reset 161The time-out to use for various stages - each connect attempt will reset
148the timeout, as will read or write activity. Default timeout is 5 minutes. 162the timeout, as will read or write activity, i.e. this is not an overall
163timeout.
164
165Default timeout is 5 minutes.
149 166
150=item proxy => [$host, $port[, $scheme]] or undef 167=item proxy => [$host, $port[, $scheme]] or undef
151 168
152Use the given http proxy for all requests. If not specified, then the 169Use the given http proxy for all requests. If not specified, then the
153default proxy (as specified by C<$ENV{http_proxy}>) is used. 170default proxy (as specified by C<$ENV{http_proxy}>) is used.
154 171
155C<$scheme> must be either missing or C<http> for HTTP, or C<https> for 172C<$scheme> must be either missing, C<http> for HTTP or C<https> for
156HTTPS. 173HTTPS.
157 174
158=item body => $string 175=item body => $string
159 176
160The request body, usually empty. Will be-sent as-is (future versions of 177The request body, usually empty. Will be-sent as-is (future versions of
… …
186verification) TLS context. 203verification) TLS context.
187 204
188The default for this option is C<low>, which could be interpreted as "give 205The default for this option is C<low>, which could be interpreted as "give
189me the page, no matter what". 206me the page, no matter what".
190 207
208=item on_prepare => $callback->($fh)
209
210In rare cases you need to "tune" the socket before it is used to
211connect (for exmaple, to bind it on a given IP address). This parameter
212overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
213and behaves exactly the same way (e.g. it has to provide a
214timeout). See the description for the C<$prepare_cb> argument of
215C<AnyEvent::Socket::tcp_connect> for details.
216
191=item on_header => $callback->($headers) 217=item on_header => $callback->($headers)
192 218
193When specified, this callback will be called with the header hash as soon 219When specified, this callback will be called with the header hash as soon
194as headers have been successfully received from the remote server (not on 220as headers have been successfully received from the remote server (not on
195locally-generated errors). 221locally-generated errors).
… …
221This callback is useful when the data is too large to be held in memory 247This callback is useful when the data is too large to be held in memory
222(so the callback writes it to a file) or when only some information should 248(so the callback writes it to a file) or when only some information should
223be extracted, or when the body should be processed incrementally. 249be extracted, or when the body should be processed incrementally.
224 250
225It is usually preferred over doing your own body handling via 251It is usually preferred over doing your own body handling via
226C<want_body_handle>. 252C<want_body_handle>, but in case of streaming APIs, where HTTP is
253only used to create a connection, C<want_body_handle> is the better
254alternative, as it allows you to install your own event handler, reducing
255resource usage.
227 256
228=item want_body_handle => $enable 257=item want_body_handle => $enable
229 258
230When enabled (default is disabled), the behaviour of AnyEvent::HTTP 259When enabled (default is disabled), the behaviour of AnyEvent::HTTP
231changes considerably: after parsing the headers, and instead of 260changes considerably: after parsing the headers, and instead of
… …
243This is useful with some push-type services, where, after the initial 272This is useful with some push-type services, where, after the initial
244headers, an interactive protocol is used (typical example would be the 273headers, an interactive protocol is used (typical example would be the
245push-style twitter API which starts a JSON/XML stream). 274push-style twitter API which starts a JSON/XML stream).
246 275
247If you think you need this, first have a look at C<on_body>, to see if 276If you think you need this, first have a look at C<on_body>, to see if
248that doesn'T solve your problem in a better way. 277that doesn't solve your problem in a better way.
249 278
250=back 279=back
251 280
252Example: make a simple HTTP GET request for http://www.nethype.de/ 281Example: make a simple HTTP GET request for http://www.nethype.de/
253 282
… …
309 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 338 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
310 339
311 _slot_schedule $_[0]; 340 _slot_schedule $_[0];
312} 341}
313 342
314our $qr_nl = qr<\015?\012>; 343our $qr_nl = qr{\015?\012};
315our $qr_nlnl = qr<\015?\012\015?\012>; 344our $qr_nlnl = qr{(?<![^\012])\015?\012};
316 345
317our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 346our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
318our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 347our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
319 348
320sub http_request($$@) { 349sub http_request($$@) {
… …
332 while (my ($k, $v) = each %$hdr) { 361 while (my ($k, $v) = each %$hdr) {
333 $hdr{lc $k} = $v; 362 $hdr{lc $k} = $v;
334 } 363 }
335 } 364 }
336 365
366 # pseudo headers for all subsequent responses
367 my @pseudo = (URL => $url);
368 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
369
337 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 370 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
338 371
339 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url }) 372 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo })
340 if $recurse < 0; 373 if $recurse < 0;
341 374
342 my $proxy = $arg{proxy} || $PROXY; 375 my $proxy = $arg{proxy} || $PROXY;
343 my $timeout = $arg{timeout} || $TIMEOUT; 376 my $timeout = $arg{timeout} || $TIMEOUT;
344 377
345 my ($uscheme, $uauthority, $upath, $query, $fragment) = 378 my ($uscheme, $uauthority, $upath, $query, $fragment) =
346 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 379 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|;
347 380
348 $uscheme = lc $uscheme; 381 $uscheme = lc $uscheme;
349 382
350 my $uport = $uscheme eq "http" ? 80 383 my $uport = $uscheme eq "http" ? 80
351 : $uscheme eq "https" ? 443 384 : $uscheme eq "https" ? 443
352 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", URL => $url }); 385 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo });
353 386
354 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 387 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
355 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url }); 388 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo });
356 389
357 my $uhost = $1; 390 my $uhost = $1;
358 $uport = $2 if defined $2; 391 $uport = $2 if defined $2;
359 392
393 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
394 unless exists $hdr{host};
395
360 $uhost =~ s/^\[(.*)\]$/$1/; 396 $uhost =~ s/^\[(.*)\]$/$1/;
361 $upath .= "?$query" if length $query; 397 $upath .= $query if length $query;
362 398
363 $upath =~ s%^/?%/%; 399 $upath =~ s%^/?%/%;
364 400
365 # cookie processing 401 # cookie processing
366 if (my $jar = $arg{cookie_jar}) { 402 if (my $jar = $arg{cookie_jar}) {
… …
396 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 432 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
397 433
398 if ($proxy) { 434 if ($proxy) {
399 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy); 435 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
400 436
437 $rscheme = "http" unless defined $rscheme;
438
401 # don't support https requests over https-proxy transport, 439 # don't support https requests over https-proxy transport,
402 # can't be done with tls as spec'ed, unless you double-encrypt. 440 # can't be done with tls as spec'ed, unless you double-encrypt.
403 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https"; 441 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
404 } else { 442 } else {
405 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 443 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
406 } 444 }
407 445
408 $hdr{"user-agent"} ||= $USERAGENT; 446 # leave out fragment and query string, just a heuristic
409 $hdr{referer} ||= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic 447 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer};
448 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"};
410 449
411 $hdr{host} = "$uhost:$uport";
412 $hdr{"content-length"} = length $arg{body}; 450 $hdr{"content-length"} = length $arg{body}
451 if length $arg{body} || $method ne "GET";
413 452
414 my %state = (connect_guard => 1); 453 my %state = (connect_guard => 1);
415 454
416 _get_slot $uhost, sub { 455 _get_slot $uhost, sub {
417 $state{slot_guard} = shift; 456 $state{slot_guard} = shift;
418 457
419 return unless $state{connect_guard}; 458 return unless $state{connect_guard};
420 459
421 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 460 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
422 $state{fh} = shift 461 $state{fh} = shift
462 or do {
463 my $err = "$!";
464 %state = ();
423 or return (%state = (), $cb->(undef, { Status => 599, Reason => "$!", URL => $url })); 465 return $cb->(undef, { Status => 599, Reason => $err, @pseudo });
466 };
467
424 pop; # free memory, save a tree 468 pop; # free memory, save a tree
425 469
426 return unless delete $state{connect_guard}; 470 return unless delete $state{connect_guard};
427 471
428 # get handle 472 # get handle
429 $state{handle} = new AnyEvent::Handle 473 $state{handle} = new AnyEvent::Handle
430 fh => $state{fh}, 474 fh => $state{fh},
475 peername => $rhost,
476 tls_ctx => $arg{tls_ctx},
477 # these need to be reconfigured on keepalive handles
431 timeout => $timeout, 478 timeout => $timeout,
432 peername => $rhost, 479 on_error => sub {
433 tls_ctx => $arg{tls_ctx}; 480 %state = ();
481 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo });
482 },
483 on_eof => sub {
484 %state = ();
485 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo });
486 },
487 ;
434 488
435 # limit the number of persistent connections 489 # limit the number of persistent connections
436 # keepalive not yet supported 490 # keepalive not yet supported
437 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 491# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
438 ++$KA_COUNT{$_[1]}; 492# ++$KA_COUNT{$_[1]};
439 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 493# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
440 --$KA_COUNT{$_[1]} 494# --$KA_COUNT{$_[1]}
441 }; 495# };
442 $hdr{connection} = "keep-alive"; 496# $hdr{connection} = "keep-alive";
443 } else { 497# } else {
444 delete $hdr{connection}; 498 delete $hdr{connection};
445 } 499# }
446
447 # (re-)configure handle
448 $state{handle}->on_error (sub {
449 %state = ();
450 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
451 });
452 $state{handle}->on_eof (sub {
453 %state = ();
454 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
455 });
456 500
457 $state{handle}->starttls ("connect") if $rscheme eq "https"; 501 $state{handle}->starttls ("connect") if $rscheme eq "https";
458 502
459 # handle actual, non-tunneled, request 503 # handle actual, non-tunneled, request
460 my $handle_actual_request = sub { 504 my $handle_actual_request = sub {
461 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 505 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
462 506
463 # send request 507 # send request
464 $state{handle}->push_write ( 508 $state{handle}->push_write (
465 "$method $rpath HTTP/1.0\015\012" 509 "$method $rpath HTTP/1.0\015\012"
466 . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr) 510 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
467 . "\015\012" 511 . "\015\012"
468 . (delete $arg{body}) 512 . (delete $arg{body})
469 ); 513 );
470 514
515 # return if error occured during push_write()
516 return unless %state;
517
471 %hdr = (); # reduce memory usage, save a kitten 518 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
472 519
473 # status line 520 # status line
474 $state{handle}->push_read (line => $qr_nl, sub { 521 $state{handle}->push_read (line => $qr_nl, sub {
475 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 522 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
476 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url })); 523 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", @pseudo }));
477 524
478 my %hdr = ( # response headers 525 push @pseudo,
479 HTTPVersion => ",$1", 526 HTTPVersion => $1,
480 Status => ",$2", 527 Status => $2,
481 Reason => ",$3", 528 Reason => $3,
482 URL => ",$url"
483 ); 529 ;
484 530
485 # headers, could be optimized a bit 531 # headers, could be optimized a bit
486 $state{handle}->unshift_read (line => $qr_nlnl, sub { 532 $state{handle}->unshift_read (line => $qr_nlnl, sub {
487 for ("$_[1]\012") { 533 for ("$_[1]") {
488 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 534 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
489 535
490 # things seen, not parsed: 536 # things seen, not parsed:
491 # p3pP="NON CUR OTPi OUR NOR UNI" 537 # p3pP="NON CUR OTPi OUR NOR UNI"
492 538
493 $hdr{lc $1} .= ",$2" 539 $hdr{lc $1} .= ",$2"
494 while /\G 540 while /\G
495 ([^:\000-\037]+): 541 ([^:\000-\037]*):
496 [\011\040]* 542 [\011\040]*
497 ((?: [^\012]+ | \012[\011\040] )*) 543 ((?: [^\012]+ | \012[\011\040] )*)
498 \012 544 \012
499 /gxc; 545 /gxc;
500 546
501 /\G$/ 547 /\G$/
502 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url })); 548 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo }));
503 } 549 }
504 550
551 # remove the "," prefix we added to all headers above
505 substr $_, 0, 1, "" 552 substr $_, 0, 1, ""
506 for values %hdr; 553 for values %hdr;
554
555 # patch in all pseudo headers
556 %hdr = (%hdr, @pseudo);
507 557
508 # redirect handling 558 # redirect handling
509 # microsoft and other shitheads don't give a shit for following standards, 559 # microsoft and other shitheads don't give a shit for following standards,
510 # try to support some common forms of broken Location headers. 560 # try to support some common forms of broken Location headers.
511 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { 561 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
… …
522 } 572 }
523 573
524 my $redirect; 574 my $redirect;
525 575
526 if ($recurse) { 576 if ($recurse) {
577 my $status = $hdr{Status};
578
527 if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") { 579 if (($status == 301 || $status == 302) && $method ne "POST") {
528 # apparently, mozilla et al. just change POST to GET here 580 # apparently, mozilla et al. just change POST to GET here
529 # more research is needed before we do the same 581 # more research is needed before we do the same
530 $redirect = 1; 582 $redirect = 1;
531 } elsif ($hdr{Status} == 303) { 583 } elsif ($status == 303) {
532 # even http/1.1 is unclear on how to mutate the method 584 # even http/1.1 is unclear on how to mutate the method
533 $method = "GET" unless $method eq "HEAD"; 585 $method = "GET" unless $method eq "HEAD";
534 $redirect = 1; 586 $redirect = 1;
535 } elsif ($hdr{Status} == 307 && $method =~ /^(?:GET|HEAD)$/) { 587 } elsif ($status == 307 && $method =~ /^(?:GET|HEAD)$/) {
536 $redirect = 1; 588 $redirect = 1;
537 } 589 }
538 } 590 }
539 591
540 my $finish = sub { 592 my $finish = sub {
… …
589 641
590 redo if /\G\s*,/gc; 642 redo if /\G\s*,/gc;
591 } 643 }
592 } 644 }
593 645
594 if ($redirect) { 646 if ($redirect && exists $hdr{location}) {
595 # we ignore any errors, as it is very common to receive 647 # we ignore any errors, as it is very common to receive
596 # Content-Length != 0 but no actual body 648 # Content-Length != 0 but no actual body
597 # we also access %hdr, as $_[1] might be an erro 649 # we also access %hdr, as $_[1] might be an erro
598 http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb); 650 http_request (
651 $method => $hdr{location},
652 %arg,
653 recurse => $recurse - 1,
654 Redirect => \@_,
655 $cb);
599 } else { 656 } else {
600 $cb->($_[0], $_[1]); 657 $cb->($_[0], $_[1]);
601 } 658 }
602 }; 659 };
603 660
604 my $len = $hdr{"content-length"}; 661 my $len = $hdr{"content-length"};
605 662
606 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { 663 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
607 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url }); 664 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
608 } elsif ( 665 } elsif (
609 $hdr{Status} =~ /^(?:1..|[23]04)$/ 666 $hdr{Status} =~ /^(?:1..|[23]04)$/
610 or $method eq "HEAD" 667 or $method eq "HEAD"
611 or (defined $len && !$len) 668 or (defined $len && !$len)
612 ) { 669 ) {
… …
622 $_[0]->on_read (undef); 679 $_[0]->on_read (undef);
623 680
624 $finish->(delete $state{handle}, \%hdr); 681 $finish->(delete $state{handle}, \%hdr);
625 682
626 } elsif ($arg{on_body}) { 683 } elsif ($arg{on_body}) {
627 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) }); 684 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
628 if ($len) { 685 if ($len) {
629 $_[0]->on_eof (undef); 686 $_[0]->on_eof (undef);
630 $_[0]->on_read (sub { 687 $_[0]->on_read (sub {
631 $len -= length $_[0]{rbuf}; 688 $len -= length $_[0]{rbuf};
632 689
633 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 690 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
634 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url }); 691 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
635 692
636 $len > 0 693 $len > 0
637 or $finish->("", \%hdr); 694 or $finish->("", \%hdr);
638 }); 695 });
639 } else { 696 } else {
640 $_[0]->on_eof (sub { 697 $_[0]->on_eof (sub {
641 $finish->("", \%hdr); 698 $finish->("", \%hdr);
642 }); 699 });
643 $_[0]->on_read (sub { 700 $_[0]->on_read (sub {
644 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 701 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
645 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url }); 702 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
646 }); 703 });
647 } 704 }
648 } else { 705 } else {
649 $_[0]->on_eof (undef); 706 $_[0]->on_eof (undef);
650 707
651 if ($len) { 708 if ($len) {
652 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) }); 709 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
653 $_[0]->on_read (sub { 710 $_[0]->on_read (sub {
654 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 711 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
655 if $len <= length $_[0]{rbuf}; 712 if $len <= length $_[0]{rbuf};
656 }); 713 });
657 } else { 714 } else {
658 $_[0]->on_error (sub { 715 $_[0]->on_error (sub {
659 $! == Errno::EPIPE 716 $! == Errno::EPIPE || !$!
660 ? $finish->(delete $_[0]{rbuf}, \%hdr) 717 ? $finish->(delete $_[0]{rbuf}, \%hdr)
661 : $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }); 718 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo });
662 }); 719 });
663 $_[0]->on_read (sub { }); 720 $_[0]->on_read (sub { });
664 } 721 }
665 } 722 }
666 } 723 }
… …
674 731
675 # maybe re-use $uauthority with patched port? 732 # maybe re-use $uauthority with patched port?
676 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 733 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
677 $state{handle}->push_read (line => $qr_nlnl, sub { 734 $state{handle}->push_read (line => $qr_nlnl, sub {
678 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 735 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
679 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", URL => $url })); 736 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo }));
680 737
681 if ($2 == 200) { 738 if ($2 == 200) {
682 $rpath = $upath; 739 $rpath = $upath;
683 &$handle_actual_request; 740 &$handle_actual_request;
684 } else { 741 } else {
685 %state = (); 742 %state = ();
686 $cb->(undef, { Status => $2, Reason => $3, URL => $url }); 743 $cb->(undef, { Status => $2, Reason => $3, @pseudo });
687 } 744 }
688 }); 745 });
689 } else { 746 } else {
690 &$handle_actual_request; 747 &$handle_actual_request;
691 } 748 }
692 749
693 }, sub { 750 }, $arg{on_prepare} || sub { $timeout };
694 $timeout
695 };
696 }; 751 };
697 752
698 defined wantarray && AnyEvent::Util::guard { %state = () } 753 defined wantarray && AnyEvent::Util::guard { %state = () }
699} 754}
700 755
… …
714 &http_request 769 &http_request
715} 770}
716 771
717=back 772=back
718 773
774=head2 DNS CACHING
775
776AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
777the actual connection, which in turn uses AnyEvent::DNS to resolve
778hostnames. The latter is a simple stub resolver and does no caching
779on its own. If you want DNS caching, you currently have to provide
780your own default resolver (by storing a suitable resolver object in
781C<$AnyEvent::DNS::RESOLVER>).
782
719=head2 GLOBAL FUNCTIONS AND VARIABLES 783=head2 GLOBAL FUNCTIONS AND VARIABLES
720 784
721=over 4 785=over 4
722 786
723=item AnyEvent::HTTP::set_proxy "proxy-url" 787=item AnyEvent::HTTP::set_proxy "proxy-url"
724 788
725Sets the default proxy server to use. The proxy-url must begin with a 789Sets the default proxy server to use. The proxy-url must begin with a
726string of the form C<http://host:port> (optionally C<https:...>). 790string of the form C<http://host:port> (optionally C<https:...>), croaks
791otherwise.
792
793To clear an already-set proxy, use C<undef>.
727 794
728=item $AnyEvent::HTTP::MAX_RECURSE 795=item $AnyEvent::HTTP::MAX_RECURSE
729 796
730The default value for the C<recurse> request parameter (default: C<10>). 797The default value for the C<recurse> request parameter (default: C<10>).
731 798
732=item $AnyEvent::HTTP::USERAGENT 799=item $AnyEvent::HTTP::USERAGENT
733 800
734The default value for the C<User-Agent> header (the default is 801The default value for the C<User-Agent> header (the default is
735C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>). 802C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
736 803
737=item $AnyEvent::HTTP::MAX_PERSISTENT 804=item $AnyEvent::HTTP::MAX_PER_HOST
738 805
739The maximum number of persistent connections to keep open (default: 8). 806The maximum number of concurrent connections to the same host (identified
807by the hostname). If the limit is exceeded, then the additional requests
808are queued until previous connections are closed.
740 809
741Not implemented currently. 810The default value for this is C<4>, and it is highly advisable to not
742 811increase it.
743=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
744
745The maximum time to cache a persistent connection, in seconds (default: 2).
746
747Not implemented currently.
748 812
749=item $AnyEvent::HTTP::ACTIVE 813=item $AnyEvent::HTTP::ACTIVE
750 814
751The number of active connections. This is not the number of currently 815The number of active connections. This is not the number of currently
752running requests, but the number of currently open and non-idle TCP 816running requests, but the number of currently open and non-idle TCP
… …
755=back 819=back
756 820
757=cut 821=cut
758 822
759sub set_proxy($) { 823sub set_proxy($) {
824 if (length $_[0]) {
760 $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix; 825 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
826 or Carp::croak "$_[0]: invalid proxy URL";
827 $PROXY = [$2, $3 || 3128, $1]
828 } else {
829 undef $PROXY;
830 }
761} 831}
762 832
763# initialise proxy from environment 833# initialise proxy from environment
834eval {
764set_proxy $ENV{http_proxy}; 835 set_proxy $ENV{http_proxy};
836};
765 837
766=head1 SEE ALSO 838=head1 SEE ALSO
767 839
768L<AnyEvent>. 840L<AnyEvent>.
769 841

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines