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.90 by root, Mon Jan 3 00:41:25 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 $len = $hdr{"content-length"};
790
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{on_header} && !$arg{on_header}(\%hdr)) {
798 $finish->(undef, 598 => "Request cancelled by on_header");
799 } elsif (
800 $hdr{Status} =~ /^(?:1..|204|205|304)$/
801 or $method eq "HEAD"
802 or (defined $len && $len == 0) # == 0, not !, because "0 " is true
803 ) {
804 # no body
805 $finish->("", undef, undef, 1);
806
807 } elsif (!$redirect && $arg{want_body_handle}) {
808 $_[0]->on_eof (undef);
809 $_[0]->on_error (undef);
810 $_[0]->on_read (undef);
811
812 $finish->(delete $state{handle});
813
814 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
815 my $cl = 0;
816 my $body = undef;
817 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
818
819 $state{read_chunk} = sub {
820 $_[1] =~ /^([0-9a-fA-F]+)/
821 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
822
823 my $len = hex $1;
824
825 if ($len) {
826 $cl += $len;
827
828 $_[0]->push_read (chunk => $len, sub {
829 $on_body->($_[1], \%hdr)
830 or return $finish->(undef, 598 => "Request cancelled by on_body");
831
832 $_[0]->push_read (line => sub {
833 length $_[1]
834 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
835 $_[0]->push_read (line => $state{read_chunk});
836 });
837 });
773 } else { 838 } else {
774 $cb->($_[0], \%hdr); 839 $hdr{"content-length"} ||= $cl;
840
841 $_[0]->push_read (line => $qr_nlnl, sub {
842 if (length $_[1]) {
843 for ("$_[1]") {
844 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
845
846 my $hdr = parse_hdr
847 or return $finish->(undef, $ae_error => "Garbled response trailers");
848
849 %hdr = (%hdr, %$hdr);
850 }
851 }
852
853 $finish->($body, undef, undef, 1);
854 });
775 } 855 }
776 }; 856 };
777 857
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}); 858 $_[0]->push_read (line => $state{read_chunk});
850 859
851 } elsif ($arg{on_body}) { 860 } elsif ($arg{on_body}) {
852 if (defined $len) { 861 if (defined $len) {
853 $_[0]->on_read (sub { 862 $_[0]->on_read (sub {
854 $len -= length $_[0]{rbuf}; 863 $len -= length $_[0]{rbuf};
855 864
856 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 865 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
857 or return $finish->(undef, 598 => "Request cancelled by on_body"); 866 or return $finish->(undef, 598 => "Request cancelled by on_body");
858 867
859 $len > 0 868 $len > 0
860 or $finish->("", undef, undef, 1); 869 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 } 870 });
871 } else { 871 } else {
872 $_[0]->on_eof (undef); 872 $_[0]->on_eof (sub {
873 873 $finish->("");
874 if (defined $len) { 874 });
875 $_[0]->on_read (sub { 875 $_[0]->on_read (sub {
876 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1) 876 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
877 if $len <= length $_[0]{rbuf}; 877 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 } 878 });
887 } 879 }
880 } else {
881 $_[0]->on_eof (undef);
882
883 if (defined $len) {
884 $_[0]->on_read (sub {
885 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
886 if $len <= length $_[0]{rbuf};
887 });
888 } else {
889 $_[0]->on_error (sub {
890 ($! == Errno::EPIPE || !$!)
891 ? $finish->(delete $_[0]{rbuf})
892 : $finish->(undef, $ae_error => $_[2]);
893 });
894 $_[0]->on_read (sub { });
895 }
896 }
897 };
898
899 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
900 };
901
902 my $connect_cb = sub {
903 $state{fh} = shift
904 or do {
905 my $err = "$!";
906 %state = ();
907 return $cb->(undef, { @pseudo, Status => $ae_error, Reason => $err });
888 }; 908 };
889 909
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}; 910 return unless delete $state{connect_guard};
902 911
903 # get handle 912 # get handle
904 $state{handle} = new AnyEvent::Handle 913 $state{handle} = new AnyEvent::Handle
905 fh => $state{fh}, 914 fh => $state{fh},
906 peername => $rhost, 915 peername => $rhost,
907 tls_ctx => $arg{tls_ctx}, 916 tls_ctx => $arg{tls_ctx},
908 # these need to be reconfigured on keepalive handles 917 # these need to be reconfigured on keepalive handles
909 timeout => $timeout, 918 timeout => $timeout,
910 on_error => sub { 919 on_error => sub {
911 %state = (); 920 %state = ();
912 $cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] }); 921 $cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] });
913 }, 922 },
914 on_eof => sub { 923 on_eof => sub {
915 %state = (); 924 %state = ();
916 $cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" }); 925 $cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" });
917 }, 926 },
918 ; 927 ;
919 928
920 # limit the number of persistent connections 929 # limit the number of persistent connections
921 # keepalive not yet supported 930 # keepalive not yet supported
922# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 931# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
923# ++$KA_COUNT{$_[1]}; 932# ++$KA_COUNT{$_[1]};
924# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 933# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
925# --$KA_COUNT{$_[1]} 934# --$KA_COUNT{$_[1]}
926# }; 935# };
927# $hdr{connection} = "keep-alive"; 936# $hdr{connection} = "keep-alive";
928# } 937# }
929 938
930 $state{handle}->starttls ("connect") if $rscheme eq "https"; 939 $state{handle}->starttls ("connect") if $rscheme eq "https";
931 940
932 # now handle proxy-CONNECT method 941 # now handle proxy-CONNECT method
933 if ($proxy && $uscheme eq "https") { 942 if ($proxy && $uscheme eq "https") {
934 # oh dear, we have to wrap it into a connect request 943 # oh dear, we have to wrap it into a connect request
935 944
936 # maybe re-use $uauthority with patched port? 945 # 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"); 946 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012\015\012");
938 $state{handle}->push_read (line => $qr_nlnl, sub { 947 $state{handle}->push_read (line => $qr_nlnl, sub {
939 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 948 $_[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])" })); 949 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
941 950
942 if ($2 == 200) { 951 if ($2 == 200) {
943 $rpath = $upath; 952 $rpath = $upath;
944 $handle_actual_request->(); 953 $handle_actual_request->();
945 } else { 954 } else {
946 %state = (); 955 %state = ();
947 $cb->(undef, { @pseudo, Status => $2, Reason => $3 }); 956 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
948 }
949 }); 957 }
958 });
950 } else { 959 } else {
951 $handle_actual_request->(); 960 $handle_actual_request->();
952 }
953 }; 961 }
962 };
963
964 _get_slot $uhost, sub {
965 $state{slot_guard} = shift;
966
967 return unless $state{connect_guard};
954 968
955 my $tcp_connect = $arg{tcp_connect} 969 my $tcp_connect = $arg{tcp_connect}
956 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect }; 970 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
957 971
958 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout }); 972 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });

Diff Legend

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