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.82 by root, Sun Jan 2 04:50:40 2011 UTC vs.
Revision 1.91 by root, Mon Jan 3 01:03:29 2011 UTC

… …
36 36
37=cut 37=cut
38 38
39package AnyEvent::HTTP; 39package AnyEvent::HTTP;
40 40
41use strict; 41use common::sense;
42no warnings;
43 42
44use Errno (); 43use Errno ();
45 44
46use AnyEvent 5.0 (); 45use AnyEvent 5.0 ();
47use AnyEvent::Util (); 46use AnyEvent::Util ();
… …
58our $MAX_PERSISTENT = 8; 57our $MAX_PERSISTENT = 8;
59our $PERSISTENT_TIMEOUT = 2; 58our $PERSISTENT_TIMEOUT = 2;
60our $TIMEOUT = 300; 59our $TIMEOUT = 300;
61 60
62# changing these is evil 61# changing these is evil
63our $MAX_PERSISTENT_PER_HOST = 0; 62our $MAX_PERSISTENT_PER_HOST = 2;
64our $MAX_PER_HOST = 4; 63our $MAX_PER_HOST = 4;
65 64
66our $PROXY; 65our $PROXY;
67our $ACTIVE = 0; 66our $ACTIVE = 0;
68 67
… …
170C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and 169C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
171will provide defaults at least for C<TE:>, C<Referer:> and C<User-Agent:> 170will provide defaults at least for C<TE:>, C<Referer:> and C<User-Agent:>
172(this can be suppressed by using C<undef> for these headers in which case 171(this can be suppressed by using C<undef> for these headers in which case
173they won't be sent at all). 172they won't be sent at all).
174 173
174You really should provide your own C<User-Agent:> header value that is
175appropriate for your program - I wouldn't be surprised if the default
176AnyEvent string gets blocked by webservers sooner or later.
177
175=item timeout => $seconds 178=item timeout => $seconds
176 179
177The time-out to use for various stages - each connect attempt will reset 180The time-out to use for various stages - each connect attempt will reset
178the timeout, as will read or write activity, i.e. this is not an overall 181the timeout, as will read or write activity, i.e. this is not an overall
179timeout. 182timeout.
… …
330Example: do a HTTP HEAD request on https://www.google.com/, use a 333Example: do a HTTP HEAD request on https://www.google.com/, use a
331timeout of 30 seconds. 334timeout of 30 seconds.
332 335
333 http_request 336 http_request
334 GET => "https://www.google.com", 337 GET => "https://www.google.com",
338 headers => { "user-agent" => "MySearchClient 1.0" },
335 timeout => 30, 339 timeout => 30,
336 sub { 340 sub {
337 my ($body, $hdr) = @_; 341 my ($body, $hdr) = @_;
338 use Data::Dumper; 342 use Data::Dumper;
339 print Dumper $hdr; 343 print Dumper $hdr;
… …
530 $cdom = $uhost; 534 $cdom = $uhost;
531 } 535 }
532 536
533 # store it 537 # store it
534 $jar->{version} = 1; 538 $jar->{version} = 1;
535 $jar->{$cdom}{$cpath}{$name} = \%kv; 539 $jar->{lc $cdom}{$cpath}{$name} = \%kv;
536 540
537 redo if /\G\s*,/gc; 541 redo if /\G\s*,/gc;
538 } 542 }
539} 543}
540 544
… …
607 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" }); 611 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
608 612
609 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 613 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
610 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" }); 614 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
611 615
612 my $uhost = $1; 616 my $uhost = lc $1;
613 $uport = $2 if defined $2; 617 $uport = $2 if defined $2;
614 618
615 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost" 619 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
616 unless exists $hdr{host}; 620 unless exists $hdr{host};
617 621
… …
636 $rscheme = "http" unless defined $rscheme; 640 $rscheme = "http" unless defined $rscheme;
637 641
638 # don't support https requests over https-proxy transport, 642 # don't support https requests over https-proxy transport,
639 # can't be done with tls as spec'ed, unless you double-encrypt. 643 # can't be done with tls as spec'ed, unless you double-encrypt.
640 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https"; 644 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
645
646 $rhost = lc $rhost;
647 $rscheme = lc $rscheme;
641 } else { 648 } else {
642 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 649 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
643 } 650 }
644 651
645 # leave out fragment and query string, just a heuristic 652 # leave out fragment and query string, just a heuristic
… …
647 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"}; 654 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
648 655
649 $hdr{"content-length"} = length $arg{body} 656 $hdr{"content-length"} = length $arg{body}
650 if length $arg{body} || $method ne "GET"; 657 if length $arg{body} || $method ne "GET";
651 658
652 $hdr{connection} = "close TE"; #1.1 659 my $idempotent = $method =~ /^(?:GET|HEAD|PUT|DELETE|OPTIONS|TRACE)$/;
660
661 # default value for keepalive is true iff the request is for an idempotent method
662 my $keepalive = exists $arg{keepalive}
663 ? $arg{keepalive}*1
664 : $idempotent ? $PERSISTENT_TIMEOUT : 0;
665
666 $hdr{connection} = ($keepalive ? "" : "close ") . "Te"; #1.1
653 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1 667 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
654 668
655 my %state = (connect_guard => 1); 669 my %state = (connect_guard => 1);
656 670
657 _get_slot $uhost, sub {
658 $state{slot_guard} = shift;
659
660 return unless $state{connect_guard};
661
662 my $ae_error = 595; # connecting 671 my $ae_error = 595; # connecting
663 672
664 # handle actual, non-tunneled, request 673 # handle actual, non-tunneled, request
665 my $handle_actual_request = sub { 674 my $handle_actual_request = sub {
666 $ae_error = 596; # request phase 675 $ae_error = 596; # request phase
667 676
668 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 677 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
669 678
670 # send request 679 # send request
671 $state{handle}->push_write ( 680 $state{handle}->push_write (
672 "$method $rpath HTTP/1.1\015\012" 681 "$method $rpath HTTP/1.1\015\012"
673 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 682 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
674 . "\015\012" 683 . "\015\012"
675 . (delete $arg{body}) 684 . (delete $arg{body})
676 ); 685 );
677 686
678 # return if error occured during push_write() 687 # return if error occured during push_write()
679 return unless %state; 688 return unless %state;
680 689
681 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use 690 # reduce memory usage, save a kitten, also re-use it for the response headers.
691 %hdr = ();
682 692
683 # status line and headers 693 # status line and headers
684 $state{read_response} = sub { 694 $state{read_response} = sub {
685 for ("$_[1]") { 695 for ("$_[1]") {
686 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 696 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
687 697
688 /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci 698 /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
689 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" })); 699 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
690 700
691 # 100 Continue handling 701 # 100 Continue handling
692 # should not happen as we don't send expect: 100-continue, 702 # should not happen as we don't send expect: 100-continue,
693 # but we handle it just in case. 703 # but we handle it just in case.
694 # since we send the request body regardless, if we get an error 704 # since we send the request body regardless, if we get an error
695 # we are out of-sync, which we currently do NOT handle correctly. 705 # we are out of-sync, which we currently do NOT handle correctly.
696 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response}) 706 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
697 if $2 eq 100; 707 if $2 eq 100;
698 708
699 push @pseudo, 709 push @pseudo,
700 HTTPVersion => $1, 710 HTTPVersion => $1,
701 Status => $2, 711 Status => $2,
702 Reason => $3, 712 Reason => $3,
703 ; 713 ;
704 714
705 my $hdr = parse_hdr 715 my $hdr = parse_hdr
706 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" })); 716 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
707 717
708 %hdr = (%$hdr, @pseudo); 718 %hdr = (%$hdr, @pseudo);
719 }
720
721 # redirect handling
722 # microsoft and other shitheads don't give a shit for following standards,
723 # try to support some common forms of broken Location headers.
724 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
725 $hdr{location} =~ s/^\.\/+//;
726
727 my $url = "$rscheme://$uhost:$uport";
728
729 unless ($hdr{location} =~ s/^\///) {
730 $url .= $upath;
731 $url =~ s/\/[^\/]*$//;
709 } 732 }
710 733
711 # redirect handling
712 # microsoft and other shitheads don't give a shit for following standards,
713 # try to support some common forms of broken Location headers.
714 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
715 $hdr{location} =~ s/^\.\/+//;
716
717 my $url = "$rscheme://$uhost:$uport";
718
719 unless ($hdr{location} =~ s/^\///) {
720 $url .= $upath;
721 $url =~ s/\/[^\/]*$//;
722 }
723
724 $hdr{location} = "$url/$hdr{location}"; 734 $hdr{location} = "$url/$hdr{location}";
735 }
736
737 my $redirect;
738
739 if ($recurse) {
740 my $status = $hdr{Status};
741
742 # industry standard is to redirect POST as GET for
743 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
744 # also, the UA should ask the user for 301 and 307 and POST,
745 # industry standard seems to be to simply follow.
746 # we go with the industry standard.
747 if ($status == 301 or $status == 302 or $status == 303) {
748 # HTTP/1.1 is unclear on how to mutate the method
749 $method = "GET" unless $method eq "HEAD";
750 $redirect = 1;
751 } elsif ($status == 307) {
752 $redirect = 1;
725 } 753 }
726
727 my $redirect;
728
729 if ($recurse) {
730 my $status = $hdr{Status};
731
732 # industry standard is to redirect POST as GET for
733 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
734 # also, the UA should ask the user for 301 and 307 and POST,
735 # industry standard seems to be to simply follow.
736 # we go with the industry standard.
737 if ($status == 301 or $status == 302 or $status == 303) {
738 # HTTP/1.1 is unclear on how to mutate the method
739 $method = "GET" unless $method eq "HEAD";
740 $redirect = 1;
741 } elsif ($status == 307) {
742 $redirect = 1;
743 } 754 }
755
756 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
757 my $may_keep_alive = $_[3];
758
759 $state{handle}->destroy if $state{handle};
760 %state = ();
761
762 if (defined $_[1]) {
763 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
764 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
744 } 765 }
745 766
746 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
747 my $may_keep_alive = $_[3];
748
749 $state{handle}->destroy if $state{handle};
750 %state = ();
751
752 if (defined $_[1]) {
753 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
754 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
755 }
756
757 # set-cookie processing 767 # set-cookie processing
758 if ($arg{cookie_jar}) { 768 if ($arg{cookie_jar}) {
759 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost, $hdr{date}; 769 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost, $hdr{date};
760 } 770 }
761 771
762 if ($redirect && exists $hdr{location}) { 772 if ($redirect && exists $hdr{location}) {
763 # we ignore any errors, as it is very common to receive 773 # we ignore any errors, as it is very common to receive
764 # Content-Length != 0 but no actual body 774 # Content-Length != 0 but no actual body
765 # we also access %hdr, as $_[1] might be an erro 775 # we also access %hdr, as $_[1] might be an erro
766 http_request ( 776 http_request (
767 $method => $hdr{location}, 777 $method => $hdr{location},
768 %arg, 778 %arg,
769 recurse => $recurse - 1, 779 recurse => $recurse - 1,
770 Redirect => [$_[0], \%hdr], 780 Redirect => [$_[0], \%hdr],
771 $cb); 781 $cb);
782 } else {
783 $cb->($_[0], \%hdr);
784 }
785 };
786
787 $ae_error = 597; # body phase
788
789 my $chunked = $hdr{"transfer-encoding"} =~ /\bchunked\b/i; # not quite correct...
790
791 my $len = $chunked ? undef : $hdr{"content-length"};
792
793 # body handling, many different code paths
794 # - no body expected
795 # - want_body_handle
796 # - te chunked
797 # - 2x length known (with or without on_body)
798 # - 2x length not known (with or without on_body)
799 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
800 $finish->(undef, 598 => "Request cancelled by on_header");
801 } elsif (
802 $hdr{Status} =~ /^(?:1..|204|205|304)$/
803 or $method eq "HEAD"
804 or (defined $len && $len == 0) # == 0, not !, because "0 " is true
805 ) {
806 # no body
807 $finish->("", undef, undef, 1);
808
809 } elsif (!$redirect && $arg{want_body_handle}) {
810 $_[0]->on_eof (undef);
811 $_[0]->on_error (undef);
812 $_[0]->on_read (undef);
813
814 $finish->(delete $state{handle});
815
816 } elsif ($chunked) {
817 my $cl = 0;
818 my $body = undef;
819 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
820
821 $state{read_chunk} = sub {
822 $_[1] =~ /^([0-9a-fA-F]+)/
823 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
824
825 my $len = hex $1;
826
827 if ($len) {
828 $cl += $len;
829
830 $_[0]->push_read (chunk => $len, sub {
831 $on_body->($_[1], \%hdr)
832 or return $finish->(undef, 598 => "Request cancelled by on_body");
833
834 $_[0]->push_read (line => sub {
835 length $_[1]
836 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
837 $_[0]->push_read (line => $state{read_chunk});
838 });
839 });
772 } else { 840 } else {
773 $cb->($_[0], \%hdr); 841 $hdr{"content-length"} ||= $cl;
842
843 $_[0]->push_read (line => $qr_nlnl, sub {
844 if (length $_[1]) {
845 for ("$_[1]") {
846 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
847
848 my $hdr = parse_hdr
849 or return $finish->(undef, $ae_error => "Garbled response trailers");
850
851 %hdr = (%hdr, %$hdr);
852 }
853 }
854
855 $finish->($body, undef, undef, 1);
856 });
774 } 857 }
775 }; 858 };
776 859
777 $ae_error = 597; # body phase 860 $_[0]->push_read (line => $state{read_chunk});
778 861
779 my $len = $hdr{"content-length"}; 862 } elsif ($arg{on_body}) {
863 if (defined $len) {
864 $_[0]->on_read (sub {
865 $len -= length $_[0]{rbuf};
780 866
781 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { 867 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
782 $finish->(undef, 598 => "Request cancelled by on_header"); 868 or return $finish->(undef, 598 => "Request cancelled by on_body");
783 } elsif ( 869
784 $hdr{Status} =~ /^(?:1..|204|205|304)$/ 870 $len > 0
785 or $method eq "HEAD"
786 or (defined $len && !$len)
787 ) {
788 # no body
789 $finish->("", undef, undef, 1); 871 or $finish->("", undef, undef, 1);
872 });
790 } else { 873 } else {
791 # body handling, many different code paths
792 # - no body expected
793 # - want_body_handle
794 # - te chunked
795 # - 2x length known (with or without on_body)
796 # - 2x length not known (with or without on_body)
797 if (!$redirect && $arg{want_body_handle}) {
798 $_[0]->on_eof (undef); 874 $_[0]->on_eof (sub {
799 $_[0]->on_error (undef); 875 $finish->("");
800 $_[0]->on_read (undef);
801
802 $finish->(delete $state{handle});
803
804 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
805 my $cl = 0;
806 my $body = undef;
807 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
808
809 $state{read_chunk} = sub {
810 $_[1] =~ /^([0-9a-fA-F]+)/
811 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
812
813 my $len = hex $1;
814
815 if ($len) {
816 $cl += $len;
817
818 $_[0]->push_read (chunk => $len, sub {
819 $on_body->($_[1], \%hdr)
820 or return $finish->(undef, 598 => "Request cancelled by on_body");
821
822 $_[0]->push_read (line => sub {
823 length $_[1]
824 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
825 $_[0]->push_read (line => $state{read_chunk});
826 });
827 });
828 } else {
829 $hdr{"content-length"} ||= $cl;
830
831 $_[0]->push_read (line => $qr_nlnl, sub {
832 if (length $_[1]) {
833 for ("$_[1]") {
834 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
835
836 my $hdr = parse_hdr
837 or return $finish->(undef, $ae_error => "Garbled response trailers");
838
839 %hdr = (%hdr, %$hdr);
840 }
841 }
842
843 $finish->($body, undef, undef, 1);
844 });
845 }
846 }; 876 });
847
848 $_[0]->push_read (line => $state{read_chunk});
849
850 } elsif ($arg{on_body}) {
851 if ($len) {
852 $_[0]->on_read (sub { 877 $_[0]->on_read (sub {
853 $len -= length $_[0]{rbuf};
854
855 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 878 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
856 or return $finish->(undef, 598 => "Request cancelled by on_body");
857
858 $len > 0
859 or $finish->("", undef, undef, 1);
860 });
861 } else {
862 $_[0]->on_eof (sub {
863 $finish->("");
864 });
865 $_[0]->on_read (sub {
866 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
867 or $finish->(undef, 598 => "Request cancelled by on_body"); 879 or $finish->(undef, 598 => "Request cancelled by on_body");
868 });
869 }
870 } else {
871 $_[0]->on_eof (undef);
872
873 if ($len) {
874 $_[0]->on_read (sub {
875 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
876 if $len <= length $_[0]{rbuf};
877 });
878 } else {
879 $_[0]->on_error (sub {
880 ($! == Errno::EPIPE || !$!)
881 ? $finish->(delete $_[0]{rbuf})
882 : $finish->(undef, $ae_error => $_[2]);
883 });
884 $_[0]->on_read (sub { });
885 }
886 } 880 });
887 } 881 }
882 } else {
883 $_[0]->on_eof (undef);
884
885 if (defined $len) {
886 $_[0]->on_read (sub {
887 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
888 if $len <= length $_[0]{rbuf};
889 });
890 } else {
891 $_[0]->on_error (sub {
892 ($! == Errno::EPIPE || !$!)
893 ? $finish->(delete $_[0]{rbuf})
894 : $finish->(undef, $ae_error => $_[2]);
895 });
896 $_[0]->on_read (sub { });
897 }
898 }
899 };
900
901 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
902 };
903
904 my $connect_cb = sub {
905 $state{fh} = shift
906 or do {
907 my $err = "$!";
908 %state = ();
909 return $cb->(undef, { @pseudo, Status => $ae_error, Reason => $err });
888 }; 910 };
889 911
890 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
891 };
892
893 my $connect_cb = sub {
894 $state{fh} = shift
895 or do {
896 my $err = "$!";
897 %state = ();
898 return $cb->(undef, { @pseudo, Status => $ae_error, Reason => $err });
899 };
900
901 return unless delete $state{connect_guard}; 912 return unless delete $state{connect_guard};
902 913
903 # get handle 914 # get handle
904 $state{handle} = new AnyEvent::Handle 915 $state{handle} = new AnyEvent::Handle
905 fh => $state{fh}, 916 fh => $state{fh},
906 peername => $rhost, 917 peername => $rhost,
907 tls_ctx => $arg{tls_ctx}, 918 tls_ctx => $arg{tls_ctx},
908 # these need to be reconfigured on keepalive handles 919 # these need to be reconfigured on keepalive handles
909 timeout => $timeout, 920 timeout => $timeout,
910 on_error => sub { 921 on_error => sub {
911 %state = (); 922 %state = ();
912 $cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] }); 923 $cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] });
913 }, 924 },
914 on_eof => sub { 925 on_eof => sub {
915 %state = (); 926 %state = ();
916 $cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" }); 927 $cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" });
917 }, 928 },
918 ; 929 ;
919 930
920 # limit the number of persistent connections 931 # limit the number of persistent connections
921 # keepalive not yet supported 932 # keepalive not yet supported
922# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 933# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
923# ++$KA_COUNT{$_[1]}; 934# ++$KA_COUNT{$_[1]};
924# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 935# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
925# --$KA_COUNT{$_[1]} 936# --$KA_COUNT{$_[1]}
926# }; 937# };
927# $hdr{connection} = "keep-alive"; 938# $hdr{connection} = "keep-alive";
928# } 939# }
929 940
930 $state{handle}->starttls ("connect") if $rscheme eq "https"; 941 $state{handle}->starttls ("connect") if $rscheme eq "https";
931 942
932 # now handle proxy-CONNECT method 943 # now handle proxy-CONNECT method
933 if ($proxy && $uscheme eq "https") { 944 if ($proxy && $uscheme eq "https") {
934 # oh dear, we have to wrap it into a connect request 945 # oh dear, we have to wrap it into a connect request
935 946
936 # maybe re-use $uauthority with patched port? 947 # maybe re-use $uauthority with patched port?
937 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 948 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012\015\012");
938 $state{handle}->push_read (line => $qr_nlnl, sub { 949 $state{handle}->push_read (line => $qr_nlnl, sub {
939 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 950 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
940 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" })); 951 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
941 952
942 if ($2 == 200) { 953 if ($2 == 200) {
943 $rpath = $upath; 954 $rpath = $upath;
944 $handle_actual_request->(); 955 $handle_actual_request->();
945 } else { 956 } else {
946 %state = (); 957 %state = ();
947 $cb->(undef, { @pseudo, Status => $2, Reason => $3 }); 958 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
948 }
949 }); 959 }
960 });
950 } else { 961 } else {
951 $handle_actual_request->(); 962 $handle_actual_request->();
952 }
953 }; 963 }
964 };
965
966 _get_slot $uhost, sub {
967 $state{slot_guard} = shift;
968
969 return unless $state{connect_guard};
954 970
955 my $tcp_connect = $arg{tcp_connect} 971 my $tcp_connect = $arg{tcp_connect}
956 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect }; 972 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
957 973
958 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout }); 974 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });

Diff Legend

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