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.41 by root, Sun Jul 5 23:50:59 2009 UTC vs.
Revision 1.57 by root, Mon Sep 6 06:31:32 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.46';
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
… …
94When called in void context, nothing is returned. In other contexts, 94When called in void context, nothing is returned. In other contexts,
95C<http_request> returns a "cancellation guard" - you have to keep the 95C<http_request> returns a "cancellation guard" - you have to keep the
96object at least alive until the callback get called. If the object gets 96object at least alive until the callback get called. If the object gets
97destroyed before the callbakc is called, the request will be cancelled. 97destroyed before the callbakc is called, the request will be cancelled.
98 98
99The callback will be called with the response data as first argument 99The callback will be called with the response body data as first argument
100(or C<undef> if it wasn't available due to errors), and a hash-ref with 100(or C<undef> if an error occured), and a hash-ref with response headers as
101response headers as second 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->($hdr) 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).
196 222
… …
200 226
201This callback is useful, among other things, to quickly reject unwanted 227This callback is useful, among other things, to quickly reject unwanted
202content, which, if it is supposed to be rare, can be faster than first 228content, which, if it is supposed to be rare, can be faster than first
203doing a C<HEAD> request. 229doing a C<HEAD> request.
204 230
231Example: cancel the request unless the content-type is "text/html".
232
233 on_header => sub {
234 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
235 },
236
205=item on_body => $callback->($data, $hdr) 237=item on_body => $callback->($partial_body, $headers)
206 238
207When specified, all body data will be "filtered" through this callback. 239When specified, all body data will be passed to this callback instead of
240to the completion callback. The completion callback will get the empty
241string instead of the body data.
208 242
209The callback will incrementally receive body data, and is supposed to 243It has to return either true (in which case AnyEvent::HTTP will continue),
210return it or a modified version of it (empty strings are valid returns). 244or false, in which case AnyEvent::HTTP will cancel the download (and call
245the completion callback with an error code of C<598>).
211 246
212If the callback returns C<undef>, then the request will be cancelled. 247This callback is useful when the data is too large to be held in memory
213 248(so the callback writes it to a file) or when only some information should
214This callback is useful when you want to do some processing on the data, 249be extracted, or when the body should be processed incrementally.
215or the data is too large to be held in memory (so the callback writes it
216to a file and returns the empty string) and so on.
217 250
218It is usually preferred over doing your own body handling via 251It is usually preferred over doing your own body handling via
219C<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.
220 256
221=item want_body_handle => $enable 257=item want_body_handle => $enable
222 258
223When enabled (default is disabled), the behaviour of AnyEvent::HTTP 259When enabled (default is disabled), the behaviour of AnyEvent::HTTP
224changes considerably: after parsing the headers, and instead of 260changes considerably: after parsing the headers, and instead of
… …
236This is useful with some push-type services, where, after the initial 272This is useful with some push-type services, where, after the initial
237headers, an interactive protocol is used (typical example would be the 273headers, an interactive protocol is used (typical example would be the
238push-style twitter API which starts a JSON/XML stream). 274push-style twitter API which starts a JSON/XML stream).
239 275
240If 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
241that doesn'T solve your problem in a better way. 277that doesn't solve your problem in a better way.
242 278
243=back 279=back
244 280
245Example: make a simple HTTP GET request for http://www.nethype.de/ 281Example: make a simple HTTP GET request for http://www.nethype.de/
246 282
… …
302 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 338 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
303 339
304 _slot_schedule $_[0]; 340 _slot_schedule $_[0];
305} 341}
306 342
307our $qr_nl = qr<\015?\012>; 343our $qr_nlnl = qr{(?<![^\012])\015?\012};
308our $qr_nlnl = qr<\015?\012\015?\012>;
309 344
310our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 345our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
311our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 346our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
312 347
313sub http_request($$@) { 348sub http_request($$@) {
… …
325 while (my ($k, $v) = each %$hdr) { 360 while (my ($k, $v) = each %$hdr) {
326 $hdr{lc $k} = $v; 361 $hdr{lc $k} = $v;
327 } 362 }
328 } 363 }
329 364
365 # pseudo headers for all subsequent responses
366 my @pseudo = (URL => $url);
367 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
368
330 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 369 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
331 370
332 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url }) 371 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo })
333 if $recurse < 0; 372 if $recurse < 0;
334 373
335 my $proxy = $arg{proxy} || $PROXY; 374 my $proxy = $arg{proxy} || $PROXY;
336 my $timeout = $arg{timeout} || $TIMEOUT; 375 my $timeout = $arg{timeout} || $TIMEOUT;
337 376
338 my ($uscheme, $uauthority, $upath, $query, $fragment) = 377 my ($uscheme, $uauthority, $upath, $query, $fragment) =
339 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 378 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|;
340 379
341 $uscheme = lc $uscheme; 380 $uscheme = lc $uscheme;
342 381
343 my $uport = $uscheme eq "http" ? 80 382 my $uport = $uscheme eq "http" ? 80
344 : $uscheme eq "https" ? 443 383 : $uscheme eq "https" ? 443
345 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", URL => $url }); 384 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo });
346 385
347 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 386 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
348 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url }); 387 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo });
349 388
350 my $uhost = $1; 389 my $uhost = $1;
351 $uport = $2 if defined $2; 390 $uport = $2 if defined $2;
352 391
392 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
393 unless exists $hdr{host};
394
353 $uhost =~ s/^\[(.*)\]$/$1/; 395 $uhost =~ s/^\[(.*)\]$/$1/;
354 $upath .= "?$query" if length $query; 396 $upath .= $query if length $query;
355 397
356 $upath =~ s%^/?%/%; 398 $upath =~ s%^/?%/%;
357 399
358 # cookie processing 400 # cookie processing
359 if (my $jar = $arg{cookie_jar}) { 401 if (my $jar = $arg{cookie_jar}) {
… …
389 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 431 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
390 432
391 if ($proxy) { 433 if ($proxy) {
392 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy); 434 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
393 435
436 $rscheme = "http" unless defined $rscheme;
437
394 # don't support https requests over https-proxy transport, 438 # don't support https requests over https-proxy transport,
395 # can't be done with tls as spec'ed, unless you double-encrypt. 439 # can't be done with tls as spec'ed, unless you double-encrypt.
396 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https"; 440 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
397 } else { 441 } else {
398 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 442 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
399 } 443 }
400 444
401 $hdr{"user-agent"} ||= $USERAGENT; 445 # leave out fragment and query string, just a heuristic
402 $hdr{referer} ||= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic 446 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer};
447 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"};
403 448
404 $hdr{host} = "$uhost:$uport";
405 $hdr{"content-length"} = length $arg{body}; 449 $hdr{"content-length"} = length $arg{body}
450 if length $arg{body} || $method ne "GET";
406 451
407 my %state = (connect_guard => 1); 452 my %state = (connect_guard => 1);
408 453
409 _get_slot $uhost, sub { 454 _get_slot $uhost, sub {
410 $state{slot_guard} = shift; 455 $state{slot_guard} = shift;
411 456
412 return unless $state{connect_guard}; 457 return unless $state{connect_guard};
413 458
414 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 459 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
415 $state{fh} = shift 460 $state{fh} = shift
461 or do {
462 my $err = "$!";
463 %state = ();
416 or return (%state = (), $cb->(undef, { Status => 599, Reason => "$!", URL => $url })); 464 return $cb->(undef, { Status => 599, Reason => $err, @pseudo });
465 };
466
417 pop; # free memory, save a tree 467 pop; # free memory, save a tree
418 468
419 return unless delete $state{connect_guard}; 469 return unless delete $state{connect_guard};
420 470
421 # get handle 471 # get handle
422 $state{handle} = new AnyEvent::Handle 472 $state{handle} = new AnyEvent::Handle
423 fh => $state{fh}, 473 fh => $state{fh},
474 peername => $rhost,
475 tls_ctx => $arg{tls_ctx},
476 # these need to be reconfigured on keepalive handles
424 timeout => $timeout, 477 timeout => $timeout,
425 peername => $rhost, 478 on_error => sub {
426 tls_ctx => $arg{tls_ctx}; 479 %state = ();
480 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo });
481 },
482 on_eof => sub {
483 %state = ();
484 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo });
485 },
486 ;
427 487
428 # limit the number of persistent connections 488 # limit the number of persistent connections
429 # keepalive not yet supported 489 # keepalive not yet supported
430 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 490# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
431 ++$KA_COUNT{$_[1]}; 491# ++$KA_COUNT{$_[1]};
432 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 492# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
433 --$KA_COUNT{$_[1]} 493# --$KA_COUNT{$_[1]}
434 }; 494# };
435 $hdr{connection} = "keep-alive"; 495# $hdr{connection} = "keep-alive";
436 } else { 496# } else {
437 delete $hdr{connection}; 497 delete $hdr{connection};
438 } 498# }
439
440 # (re-)configure handle
441 $state{handle}->on_error (sub {
442 %state = ();
443 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
444 });
445 $state{handle}->on_eof (sub {
446 %state = ();
447 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
448 });
449 499
450 $state{handle}->starttls ("connect") if $rscheme eq "https"; 500 $state{handle}->starttls ("connect") if $rscheme eq "https";
451 501
452 # handle actual, non-tunneled, request 502 # handle actual, non-tunneled, request
453 my $handle_actual_request = sub { 503 my $handle_actual_request = sub {
454 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 504 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
455 505
456 # send request 506 # send request
457 $state{handle}->push_write ( 507 $state{handle}->push_write (
458 "$method $rpath HTTP/1.0\015\012" 508 "$method $rpath HTTP/1.0\015\012"
459 . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr) 509 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
460 . "\015\012" 510 . "\015\012"
461 . (delete $arg{body}) 511 . (delete $arg{body})
462 ); 512 );
463 513
514 # return if error occured during push_write()
515 return unless %state;
516
464 %hdr = (); # reduce memory usage, save a kitten 517 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
465 518
466 # status line 519 # status line and headers
467 $state{handle}->push_read (line => $qr_nl, sub { 520 $state{handle}->push_read (line => $qr_nlnl, sub {
468 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
469 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url }));
470
471 my %hdr = ( # response headers
472 HTTPVersion => ",$1",
473 Status => ",$2",
474 Reason => ",$3",
475 URL => ",$url"
476 );
477
478 # headers, could be optimized a bit
479 $state{handle}->unshift_read (line => $qr_nlnl, sub {
480 for ("$_[1]\012") { 521 for ("$_[1]") {
481 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 522 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
482 523
524 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc
525 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo }));
526
527 push @pseudo,
528 HTTPVersion => $1,
529 Status => $2,
530 Reason => $3,
531 ;
532
483 # things seen, not parsed: 533 # things seen, not parsed:
484 # p3pP="NON CUR OTPi OUR NOR UNI" 534 # p3pP="NON CUR OTPi OUR NOR UNI"
485 535
486 $hdr{lc $1} .= ",$2" 536 $hdr{lc $1} .= ",$2"
487 while /\G 537 while /\G
488 ([^:\000-\037]+): 538 ([^:\000-\037]*):
489 [\011\040]* 539 [\011\040]*
490 ((?: [^\012]+ | \012[\011\040] )*) 540 ((?: [^\012]+ | \012[\011\040] )*)
491 \012 541 \012
492 /gxc; 542 /gxc;
493 543
494 /\G$/ 544 /\G$/
495 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url })); 545 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo }));
546 }
547
548 # remove the "," prefix we added to all headers above
549 substr $_, 0, 1, ""
550 for values %hdr;
551
552 # patch in all pseudo headers
553 %hdr = (%hdr, @pseudo);
554
555 # redirect handling
556 # microsoft and other shitheads don't give a shit for following standards,
557 # try to support some common forms of broken Location headers.
558 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
559 $hdr{location} =~ s/^\.\/+//;
560
561 my $url = "$rscheme://$uhost:$uport";
562
563 unless ($hdr{location} =~ s/^\///) {
564 $url .= $upath;
565 $url =~ s/\/[^\/]*$//;
496 } 566 }
497 567
498 substr $_, 0, 1, ""
499 for values %hdr;
500
501 # redirect handling
502 # microsoft and other shitheads don't give a shit for following standards,
503 # try to support some common forms of broken Location headers.
504 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
505 $hdr{location} =~ s/^\.\/+//;
506
507 my $url = "$rscheme://$uhost:$uport";
508
509 unless ($hdr{location} =~ s/^\///) {
510 $url .= $upath;
511 $url =~ s/\/[^\/]*$//;
512 }
513
514 $hdr{location} = "$url/$hdr{location}"; 568 $hdr{location} = "$url/$hdr{location}";
569 }
570
571 my $redirect;
572
573 if ($recurse) {
574 my $status = $hdr{Status};
575
576 # industry standard is to redirect POST as GET for
577 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
578 # also, the UA should ask the user for 301 and 307 and POST,
579 # industry standard seems to be to simply follow.
580 # we go with the industry standard.
581 if ($status == 301 or $status == 302 or $status == 303) {
582 # HTTP/1.1 is unclear on how to mutate the method
583 $method = "GET" unless $method eq "HEAD";
584 $redirect = 1;
585 } elsif ($status == 307) {
586 $redirect = 1;
515 } 587 }
588 }
516 589
517 my $redirect; 590 my $finish = sub {
591 $state{handle}->destroy if $state{handle};
592 %state = ();
518 593
594 # set-cookie processing
519 if ($recurse) { 595 if ($arg{cookie_jar}) {
520 if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") { 596 for ($_[1]{"set-cookie"}) {
521 # apparently, mozilla et al. just change POST to GET here 597 # parse NAME=VALUE
522 # more research is needed before we do the same 598 my @kv;
599
600 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
523 $redirect = 1; 601 my $name = $1;
524 } elsif ($hdr{Status} == 303) { 602 my $value = $3;
525 # even http/1.1 is unclear on how to mutate the method 603
526 $method = "GET" unless $method eq "HEAD"; 604 unless ($value) {
605 $value = $2;
606 $value =~ s/\\(.)/$1/gs;
607 }
608
609 push @kv, $name => $value;
610
611 last unless /\G\s*;/gc;
612 }
613
614 last unless @kv;
615
616 my $name = shift @kv;
617 my %kv = (value => shift @kv, @kv);
618
619 my $cdom;
620 my $cpath = (delete $kv{path}) || "/";
621
622 if (exists $kv{domain}) {
623 $cdom = delete $kv{domain};
624
625 $cdom =~ s/^\.?/./; # make sure it starts with a "."
626
627 next if $cdom =~ /\.$/;
628
629 # this is not rfc-like and not netscape-like. go figure.
630 my $ndots = $cdom =~ y/.//;
631 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
632 } else {
633 $cdom = $uhost;
634 }
635
527 $redirect = 1; 636 # store it
528 } elsif ($hdr{Status} == 307 && $method =~ /^(?:GET|HEAD)$/) { 637 $arg{cookie_jar}{version} = 1;
529 $redirect = 1; 638 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
639
640 redo if /\G\s*,/gc;
530 } 641 }
531 } 642 }
532 643
533 my $finish = sub { 644 if ($redirect && exists $hdr{location}) {
534 $state{handle}->destroy if $state{handle}; 645 # we ignore any errors, as it is very common to receive
535 %state = (); 646 # Content-Length != 0 but no actual body
536 647 # we also access %hdr, as $_[1] might be an erro
537 # set-cookie processing 648 http_request (
538 if ($arg{cookie_jar}) { 649 $method => $hdr{location},
539 for ($_[1]{"set-cookie"}) {
540 # parse NAME=VALUE
541 my @kv;
542
543 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
544 my $name = $1;
545 my $value = $3;
546
547 unless ($value) {
548 $value = $2;
549 $value =~ s/\\(.)/$1/gs;
550 } 650 %arg,
651 recurse => $recurse - 1,
652 Redirect => \@_,
653 $cb);
654 } else {
655 $cb->($_[0], $_[1]);
656 }
657 };
551 658
552 push @kv, $name => $value; 659 my $len = $hdr{"content-length"};
553 660
554 last unless /\G\s*;/gc; 661 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
662 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
663 } elsif (
664 $hdr{Status} =~ /^(?:1..|[23]04)$/
665 or $method eq "HEAD"
666 or (defined $len && !$len)
667 ) {
668 # no body
669 $finish->("", \%hdr);
670 } else {
671 # body handling, four different code paths
672 # for want_body_handle, on_body (2x), normal (2x)
673 # we might read too much here, but it does not matter yet (no pers. connections)
674 if (!$redirect && $arg{want_body_handle}) {
675 $_[0]->on_eof (undef);
676 $_[0]->on_error (undef);
677 $_[0]->on_read (undef);
678
679 $finish->(delete $state{handle}, \%hdr);
680
681 } elsif ($arg{on_body}) {
682 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
683 if ($len) {
684 $_[0]->on_eof (undef);
685 $_[0]->on_read (sub {
686 $len -= length $_[0]{rbuf};
687
688 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
689 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
690
555 } 691 $len > 0
556 692 or $finish->("", \%hdr);
557 last unless @kv;
558
559 my $name = shift @kv;
560 my %kv = (value => shift @kv, @kv);
561
562 my $cdom;
563 my $cpath = (delete $kv{path}) || "/";
564
565 if (exists $kv{domain}) {
566 $cdom = delete $kv{domain};
567
568 $cdom =~ s/^\.?/./; # make sure it starts with a "."
569
570 next if $cdom =~ /\.$/;
571
572 # this is not rfc-like and not netscape-like. go figure.
573 my $ndots = $cdom =~ y/.//;
574 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
575 } else {
576 $cdom = $uhost;
577 }
578
579 # store it
580 $arg{cookie_jar}{version} = 1;
581 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
582
583 redo if /\G\s*,/gc;
584 } 693 });
694 } else {
695 $_[0]->on_eof (sub {
696 $finish->("", \%hdr);
697 });
698 $_[0]->on_read (sub {
699 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
700 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
701 });
585 } 702 }
703 } else {
704 $_[0]->on_eof (undef);
586 705
587 if ($redirect) { 706 if ($len) {
588 # we ignore any errors, as it is very common to receive 707 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
589 # Content-Length != 0 but no actual body 708 $_[0]->on_read (sub {
590 # we also access %hdr, as $_[1] might be an erro 709 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
591 http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb); 710 if $len <= length $_[0]{rbuf};
711 });
592 } else { 712 } else {
593 $cb->($_[0], $_[1]);
594 }
595 };
596
597 my $len = $hdr{"content-length"};
598
599 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
600 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url });
601 } elsif (
602 $hdr{Status} =~ /^(?:1..|204|304)$/
603 or $method eq "HEAD"
604 or (defined $len && !$len)
605 ) {
606 # no body
607 $finish->("", \%hdr);
608 } else {
609 # body handling, four different code paths
610 # for want_body_handle, on_body (2x), normal (2x)
611 # we might read too much here, but it does not matter yet (no pers. connections)
612 if (!$redirect && $arg{want_body_handle}) {
613 $_[0]->on_eof (undef);
614 $_[0]->on_error (undef);
615 $_[0]->on_read (undef);
616
617 $finish->(delete $state{handle}, \%hdr);
618
619 } elsif ($arg{on_body}) {
620 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
621 if ($len) {
622 $_[0]->on_eof (undef);
623 $_[0]->on_read (sub {
624 $len -= length $_[0]{rbuf};
625
626 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
627 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
628
629 $len > 0
630 or $finish->("", \%hdr);
631 });
632 } else {
633 $_[0]->on_eof (sub {
634 $finish->("", \%hdr);
635 });
636 $_[0]->on_read (sub {
637 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
638 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
639 });
640 }
641 } else {
642 $_[0]->on_eof (undef);
643
644 if ($len) {
645 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
646 $_[0]->on_read (sub {
647 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
648 if $len <= length $_[0]{rbuf};
649 });
650 } else {
651 $_[0]->on_error (sub { 713 $_[0]->on_error (sub {
652 $! == Errno::EPIPE 714 ($! == Errno::EPIPE || !$!)
653 ? $finish->(delete $_[0]{rbuf}, \%hdr) 715 ? $finish->(delete $_[0]{rbuf}, \%hdr)
654 : $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }); 716 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo });
655 }); 717 });
656 $_[0]->on_read (sub { }); 718 $_[0]->on_read (sub { });
657 }
658 } 719 }
659 } 720 }
660 }); 721 }
661 }); 722 });
662 }; 723 };
663 724
664 # now handle proxy-CONNECT method 725 # now handle proxy-CONNECT method
665 if ($proxy && $uscheme eq "https") { 726 if ($proxy && $uscheme eq "https") {
… …
667 728
668 # maybe re-use $uauthority with patched port? 729 # maybe re-use $uauthority with patched port?
669 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 730 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
670 $state{handle}->push_read (line => $qr_nlnl, sub { 731 $state{handle}->push_read (line => $qr_nlnl, sub {
671 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 732 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
672 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", URL => $url })); 733 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo }));
673 734
674 if ($2 == 200) { 735 if ($2 == 200) {
675 $rpath = $upath; 736 $rpath = $upath;
676 &$handle_actual_request; 737 &$handle_actual_request;
677 } else { 738 } else {
678 %state = (); 739 %state = ();
679 $cb->(undef, { Status => $2, Reason => $3, URL => $url }); 740 $cb->(undef, { Status => $2, Reason => $3, @pseudo });
680 } 741 }
681 }); 742 });
682 } else { 743 } else {
683 &$handle_actual_request; 744 &$handle_actual_request;
684 } 745 }
685 746
686 }, sub { 747 }, $arg{on_prepare} || sub { $timeout };
687 $timeout
688 };
689 }; 748 };
690 749
691 defined wantarray && AnyEvent::Util::guard { %state = () } 750 defined wantarray && AnyEvent::Util::guard { %state = () }
692} 751}
693 752
… …
707 &http_request 766 &http_request
708} 767}
709 768
710=back 769=back
711 770
771=head2 DNS CACHING
772
773AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
774the actual connection, which in turn uses AnyEvent::DNS to resolve
775hostnames. The latter is a simple stub resolver and does no caching
776on its own. If you want DNS caching, you currently have to provide
777your own default resolver (by storing a suitable resolver object in
778C<$AnyEvent::DNS::RESOLVER>).
779
712=head2 GLOBAL FUNCTIONS AND VARIABLES 780=head2 GLOBAL FUNCTIONS AND VARIABLES
713 781
714=over 4 782=over 4
715 783
716=item AnyEvent::HTTP::set_proxy "proxy-url" 784=item AnyEvent::HTTP::set_proxy "proxy-url"
717 785
718Sets the default proxy server to use. The proxy-url must begin with a 786Sets the default proxy server to use. The proxy-url must begin with a
719string of the form C<http://host:port> (optionally C<https:...>). 787string of the form C<http://host:port> (optionally C<https:...>), croaks
788otherwise.
789
790To clear an already-set proxy, use C<undef>.
720 791
721=item $AnyEvent::HTTP::MAX_RECURSE 792=item $AnyEvent::HTTP::MAX_RECURSE
722 793
723The default value for the C<recurse> request parameter (default: C<10>). 794The default value for the C<recurse> request parameter (default: C<10>).
724 795
725=item $AnyEvent::HTTP::USERAGENT 796=item $AnyEvent::HTTP::USERAGENT
726 797
727The default value for the C<User-Agent> header (the default is 798The default value for the C<User-Agent> header (the default is
728C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>). 799C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
729 800
730=item $AnyEvent::HTTP::MAX_PERSISTENT 801=item $AnyEvent::HTTP::MAX_PER_HOST
731 802
732The maximum number of persistent connections to keep open (default: 8). 803The maximum number of concurrent connections to the same host (identified
804by the hostname). If the limit is exceeded, then the additional requests
805are queued until previous connections are closed.
733 806
734Not implemented currently. 807The default value for this is C<4>, and it is highly advisable to not
735 808increase it.
736=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
737
738The maximum time to cache a persistent connection, in seconds (default: 2).
739
740Not implemented currently.
741 809
742=item $AnyEvent::HTTP::ACTIVE 810=item $AnyEvent::HTTP::ACTIVE
743 811
744The number of active connections. This is not the number of currently 812The number of active connections. This is not the number of currently
745running requests, but the number of currently open and non-idle TCP 813running requests, but the number of currently open and non-idle TCP
… …
748=back 816=back
749 817
750=cut 818=cut
751 819
752sub set_proxy($) { 820sub set_proxy($) {
821 if (length $_[0]) {
753 $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix; 822 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
823 or Carp::croak "$_[0]: invalid proxy URL";
824 $PROXY = [$2, $3 || 3128, $1]
825 } else {
826 undef $PROXY;
827 }
754} 828}
755 829
756# initialise proxy from environment 830# initialise proxy from environment
831eval {
757set_proxy $ENV{http_proxy}; 832 set_proxy $ENV{http_proxy};
833};
758 834
759=head1 SEE ALSO 835=head1 SEE ALSO
760 836
761L<AnyEvent>. 837L<AnyEvent>.
762 838

Diff Legend

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