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.51 by root, Fri Aug 14 15:21:33 2009 UTC vs.
Revision 1.57 by root, Mon Sep 6 06:31:32 2010 UTC

… …
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.43'; 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;
… …
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,
… …
326 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 338 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
327 339
328 _slot_schedule $_[0]; 340 _slot_schedule $_[0];
329} 341}
330 342
331our $qr_nl = qr{\015?\012};
332our $qr_nlnl = qr{(?<![^\012])\015?\012}; 343our $qr_nlnl = qr{(?<![^\012])\015?\012};
333 344
334our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 345our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
335our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 346our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
336 347
… …
349 while (my ($k, $v) = each %$hdr) { 360 while (my ($k, $v) = each %$hdr) {
350 $hdr{lc $k} = $v; 361 $hdr{lc $k} = $v;
351 } 362 }
352 } 363 }
353 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
354 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 369 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
355 370
356 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url }) 371 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo })
357 if $recurse < 0; 372 if $recurse < 0;
358 373
359 my $proxy = $arg{proxy} || $PROXY; 374 my $proxy = $arg{proxy} || $PROXY;
360 my $timeout = $arg{timeout} || $TIMEOUT; 375 my $timeout = $arg{timeout} || $TIMEOUT;
361 376
362 my ($uscheme, $uauthority, $upath, $query, $fragment) = 377 my ($uscheme, $uauthority, $upath, $query, $fragment) =
363 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 378 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|;
364 379
365 $uscheme = lc $uscheme; 380 $uscheme = lc $uscheme;
366 381
367 my $uport = $uscheme eq "http" ? 80 382 my $uport = $uscheme eq "http" ? 80
368 : $uscheme eq "https" ? 443 383 : $uscheme eq "https" ? 443
369 : 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 });
370 385
371 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 386 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
372 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url }); 387 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo });
373 388
374 my $uhost = $1; 389 my $uhost = $1;
375 $uport = $2 if defined $2; 390 $uport = $2 if defined $2;
376 391
377 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"; 392 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
393 unless exists $hdr{host};
378 394
379 $uhost =~ s/^\[(.*)\]$/$1/; 395 $uhost =~ s/^\[(.*)\]$/$1/;
380 $upath .= "?$query" if length $query; 396 $upath .= $query if length $query;
381 397
382 $upath =~ s%^/?%/%; 398 $upath =~ s%^/?%/%;
383 399
384 # cookie processing 400 # cookie processing
385 if (my $jar = $arg{cookie_jar}) { 401 if (my $jar = $arg{cookie_jar}) {
… …
428 444
429 # leave out fragment and query string, just a heuristic 445 # leave out fragment and query string, just a heuristic
430 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; 446 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer};
431 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; 447 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"};
432 448
433 $hdr{"content-length"} = length $arg{body}; 449 $hdr{"content-length"} = length $arg{body}
450 if length $arg{body} || $method ne "GET";
434 451
435 my %state = (connect_guard => 1); 452 my %state = (connect_guard => 1);
436 453
437 _get_slot $uhost, sub { 454 _get_slot $uhost, sub {
438 $state{slot_guard} = shift; 455 $state{slot_guard} = shift;
… …
442 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 459 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
443 $state{fh} = shift 460 $state{fh} = shift
444 or do { 461 or do {
445 my $err = "$!"; 462 my $err = "$!";
446 %state = (); 463 %state = ();
447 return $cb->(undef, { Status => 599, Reason => $err, URL => $url }); 464 return $cb->(undef, { Status => 599, Reason => $err, @pseudo });
448 }; 465 };
449 466
450 pop; # free memory, save a tree 467 pop; # free memory, save a tree
451 468
452 return unless delete $state{connect_guard}; 469 return unless delete $state{connect_guard};
453 470
454 # get handle 471 # get handle
455 $state{handle} = new AnyEvent::Handle 472 $state{handle} = new AnyEvent::Handle
456 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
457 timeout => $timeout, 477 timeout => $timeout,
458 peername => $rhost, 478 on_error => sub {
459 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 ;
460 487
461 # limit the number of persistent connections 488 # limit the number of persistent connections
462 # keepalive not yet supported 489 # keepalive not yet supported
463 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 490# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
464 ++$KA_COUNT{$_[1]}; 491# ++$KA_COUNT{$_[1]};
465 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 492# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
466 --$KA_COUNT{$_[1]} 493# --$KA_COUNT{$_[1]}
467 }; 494# };
468 $hdr{connection} = "keep-alive"; 495# $hdr{connection} = "keep-alive";
469 } else { 496# } else {
470 delete $hdr{connection}; 497 delete $hdr{connection};
471 } 498# }
472
473 # (re-)configure handle
474 $state{handle}->on_error (sub {
475 %state = ();
476 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
477 });
478 $state{handle}->on_eof (sub {
479 %state = ();
480 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
481 });
482 499
483 $state{handle}->starttls ("connect") if $rscheme eq "https"; 500 $state{handle}->starttls ("connect") if $rscheme eq "https";
484 501
485 # handle actual, non-tunneled, request 502 # handle actual, non-tunneled, request
486 my $handle_actual_request = sub { 503 my $handle_actual_request = sub {
… …
492 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 509 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
493 . "\015\012" 510 . "\015\012"
494 . (delete $arg{body}) 511 . (delete $arg{body})
495 ); 512 );
496 513
514 # return if error occured during push_write()
515 return unless %state;
516
497 %hdr = (); # reduce memory usage, save a kitten 517 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
498 518
499 # status line 519 # status line and headers
500 $state{handle}->push_read (line => $qr_nl, sub { 520 $state{handle}->push_read (line => $qr_nlnl, sub {
501 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
502 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url }));
503
504 my %hdr = ( # response headers
505 HTTPVersion => ",$1",
506 Status => ",$2",
507 Reason => ",$3",
508 URL => ",$url"
509 );
510
511 # headers, could be optimized a bit
512 $state{handle}->unshift_read (line => $qr_nlnl, sub {
513 for ("$_[1]") { 521 for ("$_[1]") {
514 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.
515 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
516 # things seen, not parsed: 533 # things seen, not parsed:
517 # p3pP="NON CUR OTPi OUR NOR UNI" 534 # p3pP="NON CUR OTPi OUR NOR UNI"
518 535
519 $hdr{lc $1} .= ",$2" 536 $hdr{lc $1} .= ",$2"
520 while /\G 537 while /\G
521 ([^:\000-\037]*): 538 ([^:\000-\037]*):
522 [\011\040]* 539 [\011\040]*
523 ((?: [^\012]+ | \012[\011\040] )*) 540 ((?: [^\012]+ | \012[\011\040] )*)
524 \012 541 \012
525 /gxc; 542 /gxc;
526 543
527 /\G$/ 544 /\G$/
528 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/\/[^\/]*$//;
529 } 566 }
530 567
531 substr $_, 0, 1, ""
532 for values %hdr;
533
534 # redirect handling
535 # microsoft and other shitheads don't give a shit for following standards,
536 # try to support some common forms of broken Location headers.
537 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
538 $hdr{location} =~ s/^\.\/+//;
539
540 my $url = "$rscheme://$uhost:$uport";
541
542 unless ($hdr{location} =~ s/^\///) {
543 $url .= $upath;
544 $url =~ s/\/[^\/]*$//;
545 }
546
547 $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;
548 } 587 }
588 }
549 589
550 my $redirect; 590 my $finish = sub {
591 $state{handle}->destroy if $state{handle};
592 %state = ();
551 593
594 # set-cookie processing
552 if ($recurse) { 595 if ($arg{cookie_jar}) {
553 if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") { 596 for ($_[1]{"set-cookie"}) {
554 # apparently, mozilla et al. just change POST to GET here 597 # parse NAME=VALUE
555 # more research is needed before we do the same 598 my @kv;
599
600 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
556 $redirect = 1; 601 my $name = $1;
557 } elsif ($hdr{Status} == 303) { 602 my $value = $3;
558 # even http/1.1 is unclear on how to mutate the method 603
559 $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
560 $redirect = 1; 636 # store it
561 } elsif ($hdr{Status} == 307 && $method =~ /^(?:GET|HEAD)$/) { 637 $arg{cookie_jar}{version} = 1;
562 $redirect = 1; 638 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
639
640 redo if /\G\s*,/gc;
563 } 641 }
564 } 642 }
565 643
566 my $finish = sub { 644 if ($redirect && exists $hdr{location}) {
567 $state{handle}->destroy if $state{handle}; 645 # we ignore any errors, as it is very common to receive
568 %state = (); 646 # Content-Length != 0 but no actual body
569 647 # we also access %hdr, as $_[1] might be an erro
570 # set-cookie processing 648 http_request (
571 if ($arg{cookie_jar}) { 649 $method => $hdr{location},
572 for ($_[1]{"set-cookie"}) {
573 # parse NAME=VALUE
574 my @kv;
575
576 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
577 my $name = $1;
578 my $value = $3;
579
580 unless ($value) {
581 $value = $2;
582 $value =~ s/\\(.)/$1/gs;
583 } 650 %arg,
651 recurse => $recurse - 1,
652 Redirect => \@_,
653 $cb);
654 } else {
655 $cb->($_[0], $_[1]);
656 }
657 };
584 658
585 push @kv, $name => $value; 659 my $len = $hdr{"content-length"};
586 660
587 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
588 } 691 $len > 0
589 692 or $finish->("", \%hdr);
590 last unless @kv;
591
592 my $name = shift @kv;
593 my %kv = (value => shift @kv, @kv);
594
595 my $cdom;
596 my $cpath = (delete $kv{path}) || "/";
597
598 if (exists $kv{domain}) {
599 $cdom = delete $kv{domain};
600
601 $cdom =~ s/^\.?/./; # make sure it starts with a "."
602
603 next if $cdom =~ /\.$/;
604
605 # this is not rfc-like and not netscape-like. go figure.
606 my $ndots = $cdom =~ y/.//;
607 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
608 } else {
609 $cdom = $uhost;
610 }
611
612 # store it
613 $arg{cookie_jar}{version} = 1;
614 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
615
616 redo if /\G\s*,/gc;
617 } 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 });
618 } 702 }
703 } else {
704 $_[0]->on_eof (undef);
619 705
620 if ($redirect && exists $hdr{location}) { 706 if ($len) {
621 # we ignore any errors, as it is very common to receive 707 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
622 # Content-Length != 0 but no actual body 708 $_[0]->on_read (sub {
623 # we also access %hdr, as $_[1] might be an erro 709 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
624 http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb); 710 if $len <= length $_[0]{rbuf};
711 });
625 } else { 712 } else {
626 $cb->($_[0], $_[1]);
627 }
628 };
629
630 my $len = $hdr{"content-length"};
631
632 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
633 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url });
634 } elsif (
635 $hdr{Status} =~ /^(?:1..|[23]04)$/
636 or $method eq "HEAD"
637 or (defined $len && !$len)
638 ) {
639 # no body
640 $finish->("", \%hdr);
641 } else {
642 # body handling, four different code paths
643 # for want_body_handle, on_body (2x), normal (2x)
644 # we might read too much here, but it does not matter yet (no pers. connections)
645 if (!$redirect && $arg{want_body_handle}) {
646 $_[0]->on_eof (undef);
647 $_[0]->on_error (undef);
648 $_[0]->on_read (undef);
649
650 $finish->(delete $state{handle}, \%hdr);
651
652 } elsif ($arg{on_body}) {
653 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
654 if ($len) {
655 $_[0]->on_eof (undef);
656 $_[0]->on_read (sub {
657 $len -= length $_[0]{rbuf};
658
659 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
660 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
661
662 $len > 0
663 or $finish->("", \%hdr);
664 });
665 } else {
666 $_[0]->on_eof (sub {
667 $finish->("", \%hdr);
668 });
669 $_[0]->on_read (sub {
670 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
671 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
672 });
673 }
674 } else {
675 $_[0]->on_eof (undef);
676
677 if ($len) {
678 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
679 $_[0]->on_read (sub {
680 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
681 if $len <= length $_[0]{rbuf};
682 });
683 } else {
684 $_[0]->on_error (sub { 713 $_[0]->on_error (sub {
685 $! == Errno::EPIPE || !$! 714 ($! == Errno::EPIPE || !$!)
686 ? $finish->(delete $_[0]{rbuf}, \%hdr) 715 ? $finish->(delete $_[0]{rbuf}, \%hdr)
687 : $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }); 716 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo });
688 }); 717 });
689 $_[0]->on_read (sub { }); 718 $_[0]->on_read (sub { });
690 }
691 } 719 }
692 } 720 }
693 }); 721 }
694 }); 722 });
695 }; 723 };
696 724
697 # now handle proxy-CONNECT method 725 # now handle proxy-CONNECT method
698 if ($proxy && $uscheme eq "https") { 726 if ($proxy && $uscheme eq "https") {
… …
700 728
701 # maybe re-use $uauthority with patched port? 729 # maybe re-use $uauthority with patched port?
702 $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");
703 $state{handle}->push_read (line => $qr_nlnl, sub { 731 $state{handle}->push_read (line => $qr_nlnl, sub {
704 $_[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
705 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 }));
706 734
707 if ($2 == 200) { 735 if ($2 == 200) {
708 $rpath = $upath; 736 $rpath = $upath;
709 &$handle_actual_request; 737 &$handle_actual_request;
710 } else { 738 } else {
711 %state = (); 739 %state = ();
712 $cb->(undef, { Status => $2, Reason => $3, URL => $url }); 740 $cb->(undef, { Status => $2, Reason => $3, @pseudo });
713 } 741 }
714 }); 742 });
715 } else { 743 } else {
716 &$handle_actual_request; 744 &$handle_actual_request;
717 } 745 }
… …
738 &http_request 766 &http_request
739} 767}
740 768
741=back 769=back
742 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
743=head2 GLOBAL FUNCTIONS AND VARIABLES 780=head2 GLOBAL FUNCTIONS AND VARIABLES
744 781
745=over 4 782=over 4
746 783
747=item AnyEvent::HTTP::set_proxy "proxy-url" 784=item AnyEvent::HTTP::set_proxy "proxy-url"
748 785
749Sets 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
750string 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>.
751 791
752=item $AnyEvent::HTTP::MAX_RECURSE 792=item $AnyEvent::HTTP::MAX_RECURSE
753 793
754The default value for the C<recurse> request parameter (default: C<10>). 794The default value for the C<recurse> request parameter (default: C<10>).
755 795
… …
776=back 816=back
777 817
778=cut 818=cut
779 819
780sub set_proxy($) { 820sub set_proxy($) {
821 if (length $_[0]) {
781 $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 }
782} 828}
783 829
784# initialise proxy from environment 830# initialise proxy from environment
831eval {
785set_proxy $ENV{http_proxy}; 832 set_proxy $ENV{http_proxy};
833};
786 834
787=head1 SEE ALSO 835=head1 SEE ALSO
788 836
789L<AnyEvent>. 837L<AnyEvent>.
790 838

Diff Legend

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