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.85 by root, Sun Jan 2 05:31:56 2011 UTC vs.
Revision 1.91 by root, Mon Jan 3 01:03:29 2011 UTC

… …
57our $MAX_PERSISTENT = 8; 57our $MAX_PERSISTENT = 8;
58our $PERSISTENT_TIMEOUT = 2; 58our $PERSISTENT_TIMEOUT = 2;
59our $TIMEOUT = 300; 59our $TIMEOUT = 300;
60 60
61# changing these is evil 61# changing these is evil
62our $MAX_PERSISTENT_PER_HOST = 0; 62our $MAX_PERSISTENT_PER_HOST = 2;
63our $MAX_PER_HOST = 4; 63our $MAX_PER_HOST = 4;
64 64
65our $PROXY; 65our $PROXY;
66our $ACTIVE = 0; 66our $ACTIVE = 0;
67 67
… …
169C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and 169C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
170will 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:>
171(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
172they won't be sent at all). 172they won't be sent at all).
173 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
174=item timeout => $seconds 178=item timeout => $seconds
175 179
176The 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
177the 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
178timeout. 182timeout.
… …
329Example: 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
330timeout of 30 seconds. 334timeout of 30 seconds.
331 335
332 http_request 336 http_request
333 GET => "https://www.google.com", 337 GET => "https://www.google.com",
338 headers => { "user-agent" => "MySearchClient 1.0" },
334 timeout => 30, 339 timeout => 30,
335 sub { 340 sub {
336 my ($body, $hdr) = @_; 341 my ($body, $hdr) = @_;
337 use Data::Dumper; 342 use Data::Dumper;
338 print Dumper $hdr; 343 print Dumper $hdr;
… …
414} 419}
415 420
416# extract cookies from jar 421# extract cookies from jar
417sub cookie_jar_extract($$$$) { 422sub cookie_jar_extract($$$$) {
418 my ($jar, $uscheme, $uhost, $upath) = @_; 423 my ($jar, $uscheme, $uhost, $upath) = @_;
419
420 $uhost = lc $uhost;
421 424
422 %$jar = () if $jar->{version} != 1; 425 %$jar = () if $jar->{version} != 1;
423 426
424 my @cookies; 427 my @cookies;
425 428
… …
608 : 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" });
609 612
610 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 613 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
611 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" }); 614 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
612 615
613 my $uhost = $1; 616 my $uhost = lc $1;
614 $uport = $2 if defined $2; 617 $uport = $2 if defined $2;
615 618
616 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost" 619 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
617 unless exists $hdr{host}; 620 unless exists $hdr{host};
618 621
… …
637 $rscheme = "http" unless defined $rscheme; 640 $rscheme = "http" unless defined $rscheme;
638 641
639 # don't support https requests over https-proxy transport, 642 # don't support https requests over https-proxy transport,
640 # 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.
641 $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;
642 } else { 648 } else {
643 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 649 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
644 } 650 }
645 651
646 # leave out fragment and query string, just a heuristic 652 # leave out fragment and query string, just a heuristic
… …
648 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"}; 654 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
649 655
650 $hdr{"content-length"} = length $arg{body} 656 $hdr{"content-length"} = length $arg{body}
651 if length $arg{body} || $method ne "GET"; 657 if length $arg{body} || $method ne "GET";
652 658
653 $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
654 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1 667 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
655 668
656 my %state = (connect_guard => 1); 669 my %state = (connect_guard => 1);
657 670
658 _get_slot $uhost, sub {
659 $state{slot_guard} = shift;
660
661 return unless $state{connect_guard};
662
663 my $ae_error = 595; # connecting 671 my $ae_error = 595; # connecting
664 672
665 # handle actual, non-tunneled, request 673 # handle actual, non-tunneled, request
666 my $handle_actual_request = sub { 674 my $handle_actual_request = sub {
667 $ae_error = 596; # request phase 675 $ae_error = 596; # request phase
668 676
669 $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};
670 678
671 # send request 679 # send request
672 $state{handle}->push_write ( 680 $state{handle}->push_write (
673 "$method $rpath HTTP/1.1\015\012" 681 "$method $rpath HTTP/1.1\015\012"
674 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 682 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
675 . "\015\012" 683 . "\015\012"
676 . (delete $arg{body}) 684 . (delete $arg{body})
677 ); 685 );
678 686
679 # return if error occured during push_write() 687 # return if error occured during push_write()
680 return unless %state; 688 return unless %state;
681 689
682 %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 = ();
683 692
684 # status line and headers 693 # status line and headers
685 $state{read_response} = sub { 694 $state{read_response} = sub {
686 for ("$_[1]") { 695 for ("$_[1]") {
687 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.
688 697
689 /^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
690 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" }));
691 700
692 # 100 Continue handling 701 # 100 Continue handling
693 # should not happen as we don't send expect: 100-continue, 702 # should not happen as we don't send expect: 100-continue,
694 # but we handle it just in case. 703 # but we handle it just in case.
695 # 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
696 # 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.
697 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response}) 706 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
698 if $2 eq 100; 707 if $2 eq 100;
699 708
700 push @pseudo, 709 push @pseudo,
701 HTTPVersion => $1, 710 HTTPVersion => $1,
702 Status => $2, 711 Status => $2,
703 Reason => $3, 712 Reason => $3,
704 ; 713 ;
705 714
706 my $hdr = parse_hdr 715 my $hdr = parse_hdr
707 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" }));
708 717
709 %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/\/[^\/]*$//;
710 } 732 }
711 733
712 # redirect handling
713 # microsoft and other shitheads don't give a shit for following standards,
714 # try to support some common forms of broken Location headers.
715 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
716 $hdr{location} =~ s/^\.\/+//;
717
718 my $url = "$rscheme://$uhost:$uport";
719
720 unless ($hdr{location} =~ s/^\///) {
721 $url .= $upath;
722 $url =~ s/\/[^\/]*$//;
723 }
724
725 $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;
726 } 753 }
727
728 my $redirect;
729
730 if ($recurse) {
731 my $status = $hdr{Status};
732
733 # industry standard is to redirect POST as GET for
734 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
735 # also, the UA should ask the user for 301 and 307 and POST,
736 # industry standard seems to be to simply follow.
737 # we go with the industry standard.
738 if ($status == 301 or $status == 302 or $status == 303) {
739 # HTTP/1.1 is unclear on how to mutate the method
740 $method = "GET" unless $method eq "HEAD";
741 $redirect = 1;
742 } elsif ($status == 307) {
743 $redirect = 1;
744 } 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];
745 } 765 }
746 766
747 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
748 my $may_keep_alive = $_[3];
749
750 $state{handle}->destroy if $state{handle};
751 %state = ();
752
753 if (defined $_[1]) {
754 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
755 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
756 }
757
758 # set-cookie processing 767 # set-cookie processing
759 if ($arg{cookie_jar}) { 768 if ($arg{cookie_jar}) {
760 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};
761 } 770 }
762 771
763 if ($redirect && exists $hdr{location}) { 772 if ($redirect && exists $hdr{location}) {
764 # we ignore any errors, as it is very common to receive 773 # we ignore any errors, as it is very common to receive
765 # Content-Length != 0 but no actual body 774 # Content-Length != 0 but no actual body
766 # we also access %hdr, as $_[1] might be an erro 775 # we also access %hdr, as $_[1] might be an erro
767 http_request ( 776 http_request (
768 $method => $hdr{location}, 777 $method => $hdr{location},
769 %arg, 778 %arg,
770 recurse => $recurse - 1, 779 recurse => $recurse - 1,
771 Redirect => [$_[0], \%hdr], 780 Redirect => [$_[0], \%hdr],
772 $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 });
773 } else { 840 } else {
774 $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 });
775 } 857 }
776 }; 858 };
777 859
778 $ae_error = 597; # body phase
779
780 my $len = $hdr{"content-length"};
781
782 # body handling, many different code paths
783 # - no body expected
784 # - want_body_handle
785 # - te chunked
786 # - 2x length known (with or without on_body)
787 # - 2x length not known (with or without on_body)
788 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
789 $finish->(undef, 598 => "Request cancelled by on_header");
790 } elsif (
791 $hdr{Status} =~ /^(?:1..|204|205|304)$/
792 or $method eq "HEAD"
793 or (defined $len && $len == 0) # == 0, not !, because "0 " is true
794 ) {
795 # no body
796 $finish->("", undef, undef, 1);
797
798 } elsif (!$redirect && $arg{want_body_handle}) {
799 $_[0]->on_eof (undef);
800 $_[0]->on_error (undef);
801 $_[0]->on_read (undef);
802
803 $finish->(delete $state{handle});
804
805 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
806 my $cl = 0;
807 my $body = undef;
808 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
809
810 $state{read_chunk} = sub {
811 $_[1] =~ /^([0-9a-fA-F]+)/
812 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
813
814 my $len = hex $1;
815
816 if ($len) {
817 $cl += $len;
818
819 $_[0]->push_read (chunk => $len, sub {
820 $on_body->($_[1], \%hdr)
821 or return $finish->(undef, 598 => "Request cancelled by on_body");
822
823 $_[0]->push_read (line => sub {
824 length $_[1]
825 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
826 $_[0]->push_read (line => $state{read_chunk});
827 });
828 });
829 } else {
830 $hdr{"content-length"} ||= $cl;
831
832 $_[0]->push_read (line => $qr_nlnl, sub {
833 if (length $_[1]) {
834 for ("$_[1]") {
835 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
836
837 my $hdr = parse_hdr
838 or return $finish->(undef, $ae_error => "Garbled response trailers");
839
840 %hdr = (%hdr, %$hdr);
841 }
842 }
843
844 $finish->($body, undef, undef, 1);
845 });
846 }
847 };
848
849 $_[0]->push_read (line => $state{read_chunk}); 860 $_[0]->push_read (line => $state{read_chunk});
850 861
851 } elsif ($arg{on_body}) { 862 } elsif ($arg{on_body}) {
852 if (defined $len) { 863 if (defined $len) {
853 $_[0]->on_read (sub { 864 $_[0]->on_read (sub {
854 $len -= length $_[0]{rbuf}; 865 $len -= length $_[0]{rbuf};
855 866
856 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 867 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
857 or return $finish->(undef, 598 => "Request cancelled by on_body"); 868 or return $finish->(undef, 598 => "Request cancelled by on_body");
858 869
859 $len > 0 870 $len > 0
860 or $finish->("", undef, undef, 1); 871 or $finish->("", undef, undef, 1);
861 });
862 } else {
863 $_[0]->on_eof (sub {
864 $finish->("");
865 });
866 $_[0]->on_read (sub {
867 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
868 or $finish->(undef, 598 => "Request cancelled by on_body");
869 });
870 } 872 });
871 } else { 873 } else {
872 $_[0]->on_eof (undef); 874 $_[0]->on_eof (sub {
873 875 $finish->("");
874 if (defined $len) { 876 });
875 $_[0]->on_read (sub { 877 $_[0]->on_read (sub {
876 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1) 878 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
877 if $len <= length $_[0]{rbuf}; 879 or $finish->(undef, 598 => "Request cancelled by on_body");
878 });
879 } else {
880 $_[0]->on_error (sub {
881 ($! == Errno::EPIPE || !$!)
882 ? $finish->(delete $_[0]{rbuf})
883 : $finish->(undef, $ae_error => $_[2]);
884 });
885 $_[0]->on_read (sub { });
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