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.62 by root, Thu Dec 30 04:30:24 2010 UTC vs.
Revision 1.65 by root, Fri Dec 31 03:47:32 2010 UTC

… …
47use AnyEvent::Util (); 47use AnyEvent::Util ();
48use AnyEvent::Handle (); 48use AnyEvent::Handle ();
49 49
50use base Exporter::; 50use base Exporter::;
51 51
52our $VERSION = '1.46'; 52our $VERSION = '1.5';
53 53
54our @EXPORT = qw(http_get http_post http_head http_request); 54our @EXPORT = qw(http_get http_post http_head http_request);
55 55
56our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 56our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
57our $MAX_RECURSE = 10; 57our $MAX_RECURSE = 10;
… …
100second argument. 100second argument.
101 101
102All the headers in that hash are lowercased. In addition to the response 102All the headers in that hash are lowercased. In addition to the response
103headers, the "pseudo-headers" (uppercase to avoid clashing with possible 103headers, the "pseudo-headers" (uppercase to avoid clashing with possible
104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the 104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
105three parts of the HTTP Status-Line of the same name. 105three parts of the HTTP Status-Line of the same name. If an error occurs
106during the body phase of a request, then the original C<Status> and
107C<Reason> values from the header are available as C<OrigStatus> and
108C<OrigReason>.
106 109
107The pseudo-header C<URL> contains the actual URL (which can differ from 110The pseudo-header C<URL> contains the actual URL (which can differ from
108the requested URL when following redirects - for example, you might get 111the requested URL when following redirects - for example, you might get
109an error that your URL scheme is not supported even though your URL is a 112an error that your URL scheme is not supported even though your URL is a
110valid http URL because it redirected to an ftp URL, in which case you can 113valid http URL because it redirected to an ftp URL, in which case you can
… …
147Whether to recurse requests or not, e.g. on redirects, authentication 150Whether to recurse requests or not, e.g. on redirects, authentication
148retries and so on, and how often to do so. 151retries and so on, and how often to do so.
149 152
150=item headers => hashref 153=item headers => hashref
151 154
152The request headers to use, with the header name (I<MUST be in lowercase>) 155The request headers to use. Currently, C<http_request> may provide its
153as key and header value as hash value. 156own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
154 157and will provide defaults for C<User-Agent:> and C<Referer:> (this can be
155Currently, http_request> may provide its own C<host>, C<content-length>,
156C<connection> and C<cookie> headers and will provide defaults for
157C<user-agent> and C<referer> (this can be suppressed by using a value of
158C<undef> for these headers in which case they won't be sent at all). 158suppressed by using C<undef> for these headers in which case they won't be
159sent at all).
159 160
160=item timeout => $seconds 161=item timeout => $seconds
161 162
162The time-out to use for various stages - each connect attempt will reset 163The time-out to use for various stages - each connect attempt will reset
163the timeout, as will read or write activity, i.e. this is not an overall 164the timeout, as will read or write activity, i.e. this is not an overall
… …
379 my @pseudo = (URL => $url); 380 my @pseudo = (URL => $url);
380 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect}; 381 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
381 382
382 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 383 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
383 384
384 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo }) 385 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
385 if $recurse < 0; 386 if $recurse < 0;
386 387
387 my $proxy = $arg{proxy} || $PROXY; 388 my $proxy = $arg{proxy} || $PROXY;
388 my $timeout = $arg{timeout} || $TIMEOUT; 389 my $timeout = $arg{timeout} || $TIMEOUT;
389 390
… …
392 393
393 $uscheme = lc $uscheme; 394 $uscheme = lc $uscheme;
394 395
395 my $uport = $uscheme eq "http" ? 80 396 my $uport = $uscheme eq "http" ? 80
396 : $uscheme eq "https" ? 443 397 : $uscheme eq "https" ? 443
397 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo }); 398 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
398 399
399 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 400 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
400 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo }); 401 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
401 402
402 my $uhost = $1; 403 my $uhost = $1;
403 $uport = $2 if defined $2; 404 $uport = $2 if defined $2;
404 405
405 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost" 406 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
… …
467 _get_slot $uhost, sub { 468 _get_slot $uhost, sub {
468 $state{slot_guard} = shift; 469 $state{slot_guard} = shift;
469 470
470 return unless $state{connect_guard}; 471 return unless $state{connect_guard};
471 472
472 my $tcp_connect = $arg{tcp_connect} 473 my $connect_cb = sub {
473 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
474
475 $state{connect_guard} = $tcp_connect->(
476 $rhost,
477 $rport,
478 sub {
479 $state{fh} = shift 474 $state{fh} = shift
480 or do { 475 or do {
481 my $err = "$!"; 476 my $err = "$!";
482 %state = (); 477 %state = ();
483 return $cb->(undef, { Status => 599, Reason => $err, @pseudo }); 478 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
484 }; 479 };
485 480
486 pop; # free memory, save a tree 481 pop; # free memory, save a tree
487 482
488 return unless delete $state{connect_guard}; 483 return unless delete $state{connect_guard};
489 484
490 # get handle 485 # get handle
491 $state{handle} = new AnyEvent::Handle 486 $state{handle} = new AnyEvent::Handle
492 fh => $state{fh}, 487 fh => $state{fh},
493 peername => $rhost, 488 peername => $rhost,
494 tls_ctx => $arg{tls_ctx}, 489 tls_ctx => $arg{tls_ctx},
495 # these need to be reconfigured on keepalive handles 490 # these need to be reconfigured on keepalive handles
496 timeout => $timeout, 491 timeout => $timeout,
497 on_error => sub { 492 on_error => sub {
498 %state = (); 493 %state = ();
499 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo }); 494 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
500 }, 495 },
501 on_eof => sub { 496 on_eof => sub {
502 %state = (); 497 %state = ();
503 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo }); 498 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
504 }, 499 },
505 ; 500 ;
506 501
507 # limit the number of persistent connections 502 # limit the number of persistent connections
508 # keepalive not yet supported 503 # keepalive not yet supported
509# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 504# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
510# ++$KA_COUNT{$_[1]}; 505# ++$KA_COUNT{$_[1]};
511# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 506# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
512# --$KA_COUNT{$_[1]} 507# --$KA_COUNT{$_[1]}
513# }; 508# };
514# $hdr{connection} = "keep-alive"; 509# $hdr{connection} = "keep-alive";
515# } else { 510# } else {
516 delete $hdr{connection}; 511 delete $hdr{connection};
517# } 512# }
518 513
519 $state{handle}->starttls ("connect") if $rscheme eq "https"; 514 $state{handle}->starttls ("connect") if $rscheme eq "https";
520 515
521 # handle actual, non-tunneled, request 516 # handle actual, non-tunneled, request
522 my $handle_actual_request = sub { 517 my $handle_actual_request = sub {
523 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 518 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
524 519
525 # send request 520 # send request
526 $state{handle}->push_write ( 521 $state{handle}->push_write (
527 "$method $rpath HTTP/1.0\015\012" 522 "$method $rpath HTTP/1.0\015\012"
528 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 523 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
529 . "\015\012" 524 . "\015\012"
530 . (delete $arg{body}) 525 . (delete $arg{body})
531 ); 526 );
532 527
533 # return if error occured during push_write() 528 # return if error occured during push_write()
534 return unless %state; 529 return unless %state;
535 530
536 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use 531 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
537 532
538 # status line and headers 533 # status line and headers
539 $state{handle}->push_read (line => $qr_nlnl, sub { 534 $state{handle}->push_read (line => $qr_nlnl, sub {
535 my $keepalive = pop;
536
540 for ("$_[1]") { 537 for ("$_[1]") {
541 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 538 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
542 539
543 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc 540 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc
544 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo })); 541 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
545 542
546 push @pseudo, 543 push @pseudo,
547 HTTPVersion => $1, 544 HTTPVersion => $1,
548 Status => $2, 545 Status => $2,
549 Reason => $3, 546 Reason => $3,
550 ; 547 ;
551 548
552 # things seen, not parsed: 549 # things seen, not parsed:
553 # p3pP="NON CUR OTPi OUR NOR UNI" 550 # p3pP="NON CUR OTPi OUR NOR UNI"
554 551
555 $hdr{lc $1} .= ",$2" 552 $hdr{lc $1} .= ",$2"
556 while /\G 553 while /\G
557 ([^:\000-\037]*): 554 ([^:\000-\037]*):
558 [\011\040]* 555 [\011\040]*
559 ((?: [^\012]+ | \012[\011\040] )*) 556 ((?: [^\012]+ | \012[\011\040] )*)
560 \012 557 \012
561 /gxc; 558 /gxc;
562 559
563 /\G$/ 560 /\G$/
564 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo })); 561 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
562 }
563
564 # remove the "," prefix we added to all headers above
565 substr $_, 0, 1, ""
566 for values %hdr;
567
568 # patch in all pseudo headers
569 %hdr = (%hdr, @pseudo);
570
571 # redirect handling
572 # microsoft and other shitheads don't give a shit for following standards,
573 # try to support some common forms of broken Location headers.
574 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
575 $hdr{location} =~ s/^\.\/+//;
576
577 my $url = "$rscheme://$uhost:$uport";
578
579 unless ($hdr{location} =~ s/^\///) {
580 $url .= $upath;
581 $url =~ s/\/[^\/]*$//;
565 } 582 }
566 583
567 # remove the "," prefix we added to all headers above
568 substr $_, 0, 1, ""
569 for values %hdr;
570
571 # patch in all pseudo headers
572 %hdr = (%hdr, @pseudo);
573
574 # redirect handling
575 # microsoft and other shitheads don't give a shit for following standards,
576 # try to support some common forms of broken Location headers.
577 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
578 $hdr{location} =~ s/^\.\/+//;
579
580 my $url = "$rscheme://$uhost:$uport";
581
582 unless ($hdr{location} =~ s/^\///) {
583 $url .= $upath;
584 $url =~ s/\/[^\/]*$//;
585 }
586
587 $hdr{location} = "$url/$hdr{location}"; 584 $hdr{location} = "$url/$hdr{location}";
585 }
586
587 my $redirect;
588
589 if ($recurse) {
590 my $status = $hdr{Status};
591
592 # industry standard is to redirect POST as GET for
593 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
594 # also, the UA should ask the user for 301 and 307 and POST,
595 # industry standard seems to be to simply follow.
596 # we go with the industry standard.
597 if ($status == 301 or $status == 302 or $status == 303) {
598 # HTTP/1.1 is unclear on how to mutate the method
599 $method = "GET" unless $method eq "HEAD";
600 $redirect = 1;
601 } elsif ($status == 307) {
602 $redirect = 1;
588 } 603 }
604 }
589 605
590 my $redirect; 606 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
607 $state{handle}->destroy if $state{handle};
608 %state = ();
591 609
610 if (defined $_[1]) {
611 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
612 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
613 }
614
615 # set-cookie processing
592 if ($recurse) { 616 if ($arg{cookie_jar}) {
593 my $status = $hdr{Status}; 617 for ($hdr{"set-cookie"}) {
618 # parse NAME=VALUE
619 my @kv;
594 620
595 # industry standard is to redirect POST as GET for 621 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
596 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
597 # also, the UA should ask the user for 301 and 307 and POST,
598 # industry standard seems to be to simply follow.
599 # we go with the industry standard.
600 if ($status == 301 or $status == 302 or $status == 303) {
601 # HTTP/1.1 is unclear on how to mutate the method
602 $method = "GET" unless $method eq "HEAD";
603 $redirect = 1; 622 my $name = $1;
604 } elsif ($status == 307) { 623 my $value = $3;
624
625 unless ($value) {
626 $value = $2;
627 $value =~ s/\\(.)/$1/gs;
628 }
629
630 push @kv, $name => $value;
631
632 last unless /\G\s*;/gc;
633 }
634
635 last unless @kv;
636
637 my $name = shift @kv;
638 my %kv = (value => shift @kv, @kv);
639
640 my $cdom;
641 my $cpath = (delete $kv{path}) || "/";
642
643 if (exists $kv{domain}) {
644 $cdom = delete $kv{domain};
645
646 $cdom =~ s/^\.?/./; # make sure it starts with a "."
647
648 next if $cdom =~ /\.$/;
649
650 # this is not rfc-like and not netscape-like. go figure.
651 my $ndots = $cdom =~ y/.//;
652 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
653 } else {
654 $cdom = $uhost;
655 }
656
605 $redirect = 1; 657 # store it
658 $arg{cookie_jar}{version} = 1;
659 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
660
661 redo if /\G\s*,/gc;
606 } 662 }
607 } 663 }
608 664
609 my $finish = sub { 665 if ($redirect && exists $hdr{location}) {
610 $state{handle}->destroy if $state{handle}; 666 # we ignore any errors, as it is very common to receive
611 %state = (); 667 # Content-Length != 0 but no actual body
612 668 # we also access %hdr, as $_[1] might be an erro
613 # set-cookie processing 669 http_request (
614 if ($arg{cookie_jar}) { 670 $method => $hdr{location},
615 for ($_[1]{"set-cookie"}) {
616 # parse NAME=VALUE
617 my @kv;
618
619 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
620 my $name = $1;
621 my $value = $3;
622
623 unless ($value) {
624 $value = $2;
625 $value =~ s/\\(.)/$1/gs;
626 } 671 %arg,
672 recurse => $recurse - 1,
673 Redirect => [$_[0], \%hdr],
674 $cb);
675 } else {
676 $cb->($_[0], \%hdr);
677 }
678 };
627 679
628 push @kv, $name => $value; 680 my $len = $hdr{"content-length"};
629 681
630 last unless /\G\s*;/gc; 682 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
683 $finish->(undef, 598 => "Request cancelled by on_header");
684 } elsif (
685 $hdr{Status} =~ /^(?:1..|204|205|304)$/
686 or $method eq "HEAD"
687 or (defined $len && !$len)
688 ) {
689 # no body
690 $finish->("", undef, undef, 1);
691 } else {
692 # body handling, four different code paths
693 # for want_body_handle, on_body (2x), normal (2x)
694 # we might read too much here, but it does not matter yet (no pipelining)
695 if (!$redirect && $arg{want_body_handle}) {
696 $_[0]->on_eof (undef);
697 $_[0]->on_error (undef);
698 $_[0]->on_read (undef);
699
700 $finish->(delete $state{handle});
701
702 } elsif ($arg{on_body}) {
703 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
704 if ($len) {
705 $_[0]->on_read (sub {
706 $len -= length $_[0]{rbuf};
707
708 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
709 or $finish->(undef, 598 => "Request cancelled by on_body");
710
631 } 711 $len > 0
632 712 or $finish->("", undef, undef, 1);
633 last unless @kv;
634
635 my $name = shift @kv;
636 my %kv = (value => shift @kv, @kv);
637
638 my $cdom;
639 my $cpath = (delete $kv{path}) || "/";
640
641 if (exists $kv{domain}) {
642 $cdom = delete $kv{domain};
643
644 $cdom =~ s/^\.?/./; # make sure it starts with a "."
645
646 next if $cdom =~ /\.$/;
647
648 # this is not rfc-like and not netscape-like. go figure.
649 my $ndots = $cdom =~ y/.//;
650 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
651 } else {
652 $cdom = $uhost;
653 }
654
655 # store it
656 $arg{cookie_jar}{version} = 1;
657 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
658
659 redo if /\G\s*,/gc;
660 } 713 });
714 } else {
715 $_[0]->on_eof (sub {
716 $finish->("");
717 });
718 $_[0]->on_read (sub {
719 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
720 or $finish->(undef, 598 => "Request cancelled by on_body");
721 });
661 } 722 }
723 } else {
724 $_[0]->on_eof (undef);
662 725
663 if ($redirect && exists $hdr{location}) { 726 if ($len) {
664 # we ignore any errors, as it is very common to receive 727 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
665 # Content-Length != 0 but no actual body 728 $_[0]->on_read (sub {
666 # we also access %hdr, as $_[1] might be an erro 729 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
667 http_request ( 730 if $len <= length $_[0]{rbuf};
668 $method => $hdr{location},
669 %arg,
670 recurse => $recurse - 1,
671 Redirect => \@_,
672 $cb); 731 });
673 } else { 732 } else {
674 $cb->($_[0], $_[1]);
675 }
676 };
677
678 my $len = $hdr{"content-length"};
679
680 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
681 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
682 } elsif (
683 $hdr{Status} =~ /^(?:1..|[23]04)$/
684 or $method eq "HEAD"
685 or (defined $len && !$len)
686 ) {
687 # no body
688 $finish->("", \%hdr);
689 } else {
690 # body handling, four different code paths
691 # for want_body_handle, on_body (2x), normal (2x)
692 # we might read too much here, but it does not matter yet (no pers. connections)
693 if (!$redirect && $arg{want_body_handle}) {
694 $_[0]->on_eof (undef);
695 $_[0]->on_error (undef);
696 $_[0]->on_read (undef);
697
698 $finish->(delete $state{handle}, \%hdr);
699
700 } elsif ($arg{on_body}) {
701 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
702 if ($len) {
703 $_[0]->on_eof (undef);
704 $_[0]->on_read (sub {
705 $len -= length $_[0]{rbuf};
706
707 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
708 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
709
710 $len > 0
711 or $finish->("", \%hdr);
712 });
713 } else {
714 $_[0]->on_eof (sub {
715 $finish->("", \%hdr);
716 });
717 $_[0]->on_read (sub {
718 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
719 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
720 });
721 }
722 } else {
723 $_[0]->on_eof (undef);
724
725 if ($len) {
726 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
727 $_[0]->on_read (sub {
728 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
729 if $len <= length $_[0]{rbuf};
730 });
731 } else {
732 $_[0]->on_error (sub { 733 $_[0]->on_error (sub {
733 ($! == Errno::EPIPE || !$!) 734 ($! == Errno::EPIPE || !$!)
734 ? $finish->(delete $_[0]{rbuf}, \%hdr) 735 ? $finish->(delete $_[0]{rbuf})
735 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }); 736 : $finish->(undef, 599 => $_[2]);
736 }); 737 });
737 $_[0]->on_read (sub { }); 738 $_[0]->on_read (sub { });
738 }
739 } 739 }
740 } 740 }
741 }); 741 }
742 }; 742 });
743 };
743 744
744 # now handle proxy-CONNECT method 745 # now handle proxy-CONNECT method
745 if ($proxy && $uscheme eq "https") { 746 if ($proxy && $uscheme eq "https") {
746 # oh dear, we have to wrap it into a connect request 747 # oh dear, we have to wrap it into a connect request
747 748
748 # maybe re-use $uauthority with patched port? 749 # maybe re-use $uauthority with patched port?
749 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 750 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
750 $state{handle}->push_read (line => $qr_nlnl, sub { 751 $state{handle}->push_read (line => $qr_nlnl, sub {
751 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 752 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
752 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo })); 753 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
753 754
754 if ($2 == 200) { 755 if ($2 == 200) {
755 $rpath = $upath; 756 $rpath = $upath;
756 &$handle_actual_request; 757 &$handle_actual_request;
757 } else { 758 } else {
758 %state = (); 759 %state = ();
759 $cb->(undef, { Status => $2, Reason => $3, @pseudo }); 760 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
760 }
761 }); 761 }
762 });
762 } else { 763 } else {
763 &$handle_actual_request; 764 &$handle_actual_request;
764 }
765
766 }, 765 }
767 $arg{on_prepare} || sub { $timeout }
768 ); 766 };
767
768 my $tcp_connect = $arg{tcp_connect}
769 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
770
771 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
772
769 }; 773 };
770 774
771 defined wantarray && AnyEvent::Util::guard { %state = () } 775 defined wantarray && AnyEvent::Util::guard { %state = () }
772} 776}
773 777

Diff Legend

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