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.72 by root, Fri Dec 31 20:59:19 2010 UTC vs.
Revision 1.78 by root, Sat Jan 1 19:32:41 2011 UTC

… …
122 122
123If the server sends a header multiple times, then their contents will be 123If the server sends a header multiple times, then their contents will be
124joined together with a comma (C<,>), as per the HTTP spec. 124joined together with a comma (C<,>), as per the HTTP spec.
125 125
126If an internal error occurs, such as not being able to resolve a hostname, 126If an internal error occurs, such as not being able to resolve a hostname,
127then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<59x> 127then C<$data> will be C<undef>, C<< $headers->{Status} >> will be
128(usually C<599>) and the C<Reason> pseudo-header will contain an error 128C<590>-C<599> and the C<Reason> pseudo-header will contain an error
129message. 129message. Currently the following status codes are used:
130
131=over 4
132
133=item 595 - errors during connection etsbalishment, proxy handshake.
134
135=item 596 - errors during TLS negotiation, request sending and header processing.
136
137=item 597 - errors during body receiving or processing.
138
139=item 598 - user aborted request via C<on_header> or C<on_body>.
140
141=item 599 - other, usually nonretryable, errors (garbled URL etc.).
142
143=back
130 144
131A typical callback might look like this: 145A typical callback might look like this:
132 146
133 sub { 147 sub {
134 my ($body, $hdr) = @_; 148 my ($body, $hdr) = @_;
… …
412 426
413 \@cookies 427 \@cookies
414} 428}
415 429
416# parse set_cookie header into jar 430# parse set_cookie header into jar
417sub cookie_jar_set_cookie($$) { 431sub cookie_jar_set_cookie($$$) {
418 my ($jar, $set_cookie) = @_; 432 my ($jar, $set_cookie, $uhost) = @_;
419 433
420 for ($set_cookie) { 434 for ($set_cookie) {
421 # parse NAME=VALUE 435 # parse NAME=VALUE
422 my @kv; 436 my @kv;
423 437
… …
472 } else { 486 } else {
473 $cdom = $uhost; 487 $cdom = $uhost;
474 } 488 }
475 489
476 # store it 490 # store it
477 $arg{cookie_jar}{version} = 1; 491 $jar->{version} = 1;
478 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; 492 $jar->{$cdom}{$cpath}{$name} = \%kv;
479 493
480 redo if /\G\s*,/gc; 494 redo if /\G\s*,/gc;
481 } 495 }
482}
483} 496}
484 497
485# continue to parse $_ for headers and place them into the arg 498# continue to parse $_ for headers and place them into the arg
486sub parse_hdr() { 499sub parse_hdr() {
487 my %hdr; 500 my %hdr;
… …
601 _get_slot $uhost, sub { 614 _get_slot $uhost, sub {
602 $state{slot_guard} = shift; 615 $state{slot_guard} = shift;
603 616
604 return unless $state{connect_guard}; 617 return unless $state{connect_guard};
605 618
619 my $ae_error = 595; # connecting
620
606 my $connect_cb = sub { 621 my $connect_cb = sub {
607 $state{fh} = shift 622 $state{fh} = shift
608 or do { 623 or do {
609 my $err = "$!"; 624 my $err = "$!";
610 %state = (); 625 %state = ();
611 return $cb->(undef, { @pseudo, Status => 599, Reason => $err }); 626 return $cb->(undef, { @pseudo, Status => $ae_error, Reason => $err });
612 }; 627 };
613
614 pop; # free memory, save a tree
615 628
616 return unless delete $state{connect_guard}; 629 return unless delete $state{connect_guard};
617 630
618 # get handle 631 # get handle
619 $state{handle} = new AnyEvent::Handle 632 $state{handle} = new AnyEvent::Handle
… …
622 tls_ctx => $arg{tls_ctx}, 635 tls_ctx => $arg{tls_ctx},
623 # these need to be reconfigured on keepalive handles 636 # these need to be reconfigured on keepalive handles
624 timeout => $timeout, 637 timeout => $timeout,
625 on_error => sub { 638 on_error => sub {
626 %state = (); 639 %state = ();
627 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] }); 640 $cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] });
628 }, 641 },
629 on_eof => sub { 642 on_eof => sub {
630 %state = (); 643 %state = ();
631 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" }); 644 $cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" });
632 }, 645 },
633 ; 646 ;
634 647
635 # limit the number of persistent connections 648 # limit the number of persistent connections
636 # keepalive not yet supported 649 # keepalive not yet supported
… …
644 657
645 $state{handle}->starttls ("connect") if $rscheme eq "https"; 658 $state{handle}->starttls ("connect") if $rscheme eq "https";
646 659
647 # handle actual, non-tunneled, request 660 # handle actual, non-tunneled, request
648 my $handle_actual_request = sub { 661 my $handle_actual_request = sub {
662 $ae_error = 596; # request phase
663
649 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 664 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
650 665
651 # send request 666 # send request
652 $state{handle}->push_write ( 667 $state{handle}->push_write (
653 "$method $rpath HTTP/1.1\015\012" 668 "$method $rpath HTTP/1.1\015\012"
… …
664 # status line and headers 679 # status line and headers
665 $state{read_response} = sub { 680 $state{read_response} = sub {
666 for ("$_[1]") { 681 for ("$_[1]") {
667 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 682 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
668 683
669 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc 684 /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
670 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" })); 685 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
671 686
672 # 100 Continue handling 687 # 100 Continue handling
673 # should not happen as we don't send expect: 100-continue, 688 # should not happen as we don't send expect: 100-continue,
674 # but we handle it just in case. 689 # but we handle it just in case.
… …
709 724
710 if ($recurse) { 725 if ($recurse) {
711 my $status = $hdr{Status}; 726 my $status = $hdr{Status};
712 727
713 # industry standard is to redirect POST as GET for 728 # industry standard is to redirect POST as GET for
714 # 301, 302 and 303, in contrast to http/1.0 and 1.1. 729 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
715 # also, the UA should ask the user for 301 and 307 and POST, 730 # also, the UA should ask the user for 301 and 307 and POST,
716 # industry standard seems to be to simply follow. 731 # industry standard seems to be to simply follow.
717 # we go with the industry standard. 732 # we go with the industry standard.
718 if ($status == 301 or $status == 302 or $status == 303) { 733 if ($status == 301 or $status == 302 or $status == 303) {
719 # HTTP/1.1 is unclear on how to mutate the method 734 # HTTP/1.1 is unclear on how to mutate the method
… …
723 $redirect = 1; 738 $redirect = 1;
724 } 739 }
725 } 740 }
726 741
727 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 742 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
728 my $keepalive = pop; 743 my $may_keep_alive = $_[3];
729 744
730 $state{handle}->destroy if $state{handle}; 745 $state{handle}->destroy if $state{handle};
731 %state = (); 746 %state = ();
732 747
733 if (defined $_[1]) { 748 if (defined $_[1]) {
… …
735 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2]; 750 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
736 } 751 }
737 752
738 # set-cookie processing 753 # set-cookie processing
739 if ($arg{cookie_jar}) { 754 if ($arg{cookie_jar}) {
740 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}; 755 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost;
756 }
741 757
742 if ($redirect && exists $hdr{location}) { 758 if ($redirect && exists $hdr{location}) {
743 # we ignore any errors, as it is very common to receive 759 # we ignore any errors, as it is very common to receive
744 # Content-Length != 0 but no actual body 760 # Content-Length != 0 but no actual body
745 # we also access %hdr, as $_[1] might be an erro 761 # we also access %hdr, as $_[1] might be an erro
… …
751 $cb); 767 $cb);
752 } else { 768 } else {
753 $cb->($_[0], \%hdr); 769 $cb->($_[0], \%hdr);
754 } 770 }
755 }; 771 };
772
773 $ae_error = 597; # body phase
756 774
757 my $len = $hdr{"content-length"}; 775 my $len = $hdr{"content-length"};
758 776
759 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { 777 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
760 $finish->(undef, 598 => "Request cancelled by on_header"); 778 $finish->(undef, 598 => "Request cancelled by on_header");
… …
782 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) { 800 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
783 my $cl = 0; 801 my $cl = 0;
784 my $body = undef; 802 my $body = undef;
785 my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; 803 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
786 804
787 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
788
789 my $read_chunk; $read_chunk = sub { 805 my $read_chunk; $read_chunk = sub {
790 $_[1] =~ /^([0-9a-fA-F]+)/ 806 $_[1] =~ /^([0-9a-fA-F]+)/
791 or $finish->(undef, 599 => "Garbled chunked transfer encoding"); 807 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
792 808
793 my $len = hex $1; 809 my $len = hex $1;
794 810
795 if ($len) { 811 if ($len) {
796 $cl += $len; 812 $cl += $len;
… …
799 $on_body->($_[1], \%hdr) 815 $on_body->($_[1], \%hdr)
800 or return $finish->(undef, 598 => "Request cancelled by on_body"); 816 or return $finish->(undef, 598 => "Request cancelled by on_body");
801 817
802 $_[0]->push_read (line => sub { 818 $_[0]->push_read (line => sub {
803 length $_[1] 819 length $_[1]
804 and return $finish->(undef, 599 => "Garbled chunked transfer encoding"); 820 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
805 $_[0]->push_read (line => $read_chunk); 821 $_[0]->push_read (line => $read_chunk);
806 }); 822 });
807 }); 823 });
808 } else { 824 } else {
809 $hdr{"content-length"} ||= $cl; 825 $hdr{"content-length"} ||= $cl;
… …
812 if (length $_[1]) { 828 if (length $_[1]) {
813 for ("$_[1]") { 829 for ("$_[1]") {
814 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 830 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
815 831
816 my $hdr = parse_hdr 832 my $hdr = parse_hdr
817 or return $finish->(undef, 599 => "Garbled response trailers"); 833 or return $finish->(undef, $ae_error => "Garbled response trailers");
818 834
819 %hdr = (%hdr, %$hdr); 835 %hdr = (%hdr, %$hdr);
820 } 836 }
821 } 837 }
822 838
… …
826 }; 842 };
827 843
828 $_[0]->push_read (line => $read_chunk); 844 $_[0]->push_read (line => $read_chunk);
829 845
830 } elsif ($arg{on_body}) { 846 } elsif ($arg{on_body}) {
831 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
832
833 if ($len) { 847 if ($len) {
834 $_[0]->on_read (sub { 848 $_[0]->on_read (sub {
835 $len -= length $_[0]{rbuf}; 849 $len -= length $_[0]{rbuf};
836 850
837 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 851 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
… …
851 } 865 }
852 } else { 866 } else {
853 $_[0]->on_eof (undef); 867 $_[0]->on_eof (undef);
854 868
855 if ($len) { 869 if ($len) {
856 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
857 $_[0]->on_read (sub { 870 $_[0]->on_read (sub {
858 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1) 871 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
859 if $len <= length $_[0]{rbuf}; 872 if $len <= length $_[0]{rbuf};
860 }); 873 });
861 } else { 874 } else {
862 $_[0]->on_error (sub { 875 $_[0]->on_error (sub {
863 ($! == Errno::EPIPE || !$!) 876 ($! == Errno::EPIPE || !$!)
864 ? $finish->(delete $_[0]{rbuf}) 877 ? $finish->(delete $_[0]{rbuf})
865 : $finish->(undef, 599 => $_[2]); 878 : $finish->(undef, $ae_error => $_[2]);
866 }); 879 });
867 $_[0]->on_read (sub { }); 880 $_[0]->on_read (sub { });
868 } 881 }
869 } 882 }
870 } 883 }

Diff Legend

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