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.63 by root, Thu Dec 30 04:31:55 2010 UTC vs.
Revision 1.66 by root, Fri Dec 31 06:18:30 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
… …
349 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 352 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
350 353
351 _slot_schedule $_[0]; 354 _slot_schedule $_[0];
352} 355}
353 356
357# continue to parse $_ for headers and place them into the arg
358sub parse_hdr() {
359 my %hdr;
360
361 # things seen, not parsed:
362 # p3pP="NON CUR OTPi OUR NOR UNI"
363
364 $hdr{lc $1} .= ",$2"
365 while /\G
366 ([^:\000-\037]*):
367 [\011\040]*
368 ((?: [^\012]+ | \012[\011\040] )*)
369 \012
370 /gxc;
371
372 /\G$/
373 or return;
374
375 # remove the "," prefix we added to all headers above
376 substr $_, 0, 1, ""
377 for values %hdr;
378
379 \%hdr
380}
381
354our $qr_nlnl = qr{(?<![^\012])\015?\012}; 382our $qr_nlnl = qr{(?<![^\012])\015?\012};
355 383
356our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 384our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
357our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 385our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
358 386
… …
377 my @pseudo = (URL => $url); 405 my @pseudo = (URL => $url);
378 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect}; 406 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
379 407
380 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 408 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
381 409
382 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo }) 410 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
383 if $recurse < 0; 411 if $recurse < 0;
384 412
385 my $proxy = $arg{proxy} || $PROXY; 413 my $proxy = $arg{proxy} || $PROXY;
386 my $timeout = $arg{timeout} || $TIMEOUT; 414 my $timeout = $arg{timeout} || $TIMEOUT;
387 415
… …
390 418
391 $uscheme = lc $uscheme; 419 $uscheme = lc $uscheme;
392 420
393 my $uport = $uscheme eq "http" ? 80 421 my $uport = $uscheme eq "http" ? 80
394 : $uscheme eq "https" ? 443 422 : $uscheme eq "https" ? 443
395 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo }); 423 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
396 424
397 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 425 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
398 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo }); 426 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
399 427
400 my $uhost = $1; 428 my $uhost = $1;
401 $uport = $2 if defined $2; 429 $uport = $2 if defined $2;
402 430
403 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost" 431 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
… …
452 } else { 480 } else {
453 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 481 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
454 } 482 }
455 483
456 # leave out fragment and query string, just a heuristic 484 # leave out fragment and query string, just a heuristic
457 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; 485 $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
458 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; 486 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
459 487
460 $hdr{"content-length"} = length $arg{body} 488 $hdr{"content-length"} = length $arg{body}
461 if length $arg{body} || $method ne "GET"; 489 if length $arg{body} || $method ne "GET";
462 490
491 $hdr{connection} = "close TE";
492 $hdr{te} = "trailers" unless exists $hdr{te};
493
463 my %state = (connect_guard => 1); 494 my %state = (connect_guard => 1);
464 495
465 _get_slot $uhost, sub { 496 _get_slot $uhost, sub {
466 $state{slot_guard} = shift; 497 $state{slot_guard} = shift;
467 498
468 return unless $state{connect_guard}; 499 return unless $state{connect_guard};
469 500
470 my $tcp_connect = $arg{tcp_connect} 501 my $connect_cb = sub {
471 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
472
473 $state{connect_guard} = $tcp_connect->(
474 $rhost,
475 $rport,
476 sub {
477 $state{fh} = shift 502 $state{fh} = shift
478 or do { 503 or do {
479 my $err = "$!"; 504 my $err = "$!";
480 %state = (); 505 %state = ();
481 return $cb->(undef, { Status => 599, Reason => $err, @pseudo }); 506 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
482 }; 507 };
483 508
484 pop; # free memory, save a tree 509 pop; # free memory, save a tree
485 510
486 return unless delete $state{connect_guard}; 511 return unless delete $state{connect_guard};
487 512
488 # get handle 513 # get handle
489 $state{handle} = new AnyEvent::Handle 514 $state{handle} = new AnyEvent::Handle
490 fh => $state{fh}, 515 fh => $state{fh},
491 peername => $rhost, 516 peername => $rhost,
492 tls_ctx => $arg{tls_ctx}, 517 tls_ctx => $arg{tls_ctx},
493 # these need to be reconfigured on keepalive handles 518 # these need to be reconfigured on keepalive handles
494 timeout => $timeout, 519 timeout => $timeout,
495 on_error => sub { 520 on_error => sub {
496 %state = (); 521 %state = ();
497 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo }); 522 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
498 }, 523 },
499 on_eof => sub { 524 on_eof => sub {
500 %state = (); 525 %state = ();
501 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo }); 526 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
502 }, 527 },
503 ; 528 ;
504 529
505 # limit the number of persistent connections 530 # limit the number of persistent connections
506 # keepalive not yet supported 531 # keepalive not yet supported
507# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 532# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
508# ++$KA_COUNT{$_[1]}; 533# ++$KA_COUNT{$_[1]};
509# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 534# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
510# --$KA_COUNT{$_[1]} 535# --$KA_COUNT{$_[1]}
511# }; 536# };
512# $hdr{connection} = "keep-alive"; 537# $hdr{connection} = "keep-alive";
513# } else { 538# } else {
514 delete $hdr{connection}; 539# delete $hdr{connection};
515# } 540# }
516 541
517 $state{handle}->starttls ("connect") if $rscheme eq "https"; 542 $state{handle}->starttls ("connect") if $rscheme eq "https";
518 543
519 # handle actual, non-tunneled, request 544 # handle actual, non-tunneled, request
520 my $handle_actual_request = sub { 545 my $handle_actual_request = sub {
521 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 546 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
522 547
523 # send request 548 # send request
524 $state{handle}->push_write ( 549 $state{handle}->push_write (
525 "$method $rpath HTTP/1.0\015\012" 550 "$method $rpath HTTP/1.1\015\012"
526 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 551 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
527 . "\015\012" 552 . "\015\012"
528 . (delete $arg{body}) 553 . (delete $arg{body})
529 ); 554 );
530 555
531 # return if error occured during push_write() 556 # return if error occured during push_write()
532 return unless %state; 557 return unless %state;
533 558
534 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use 559 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
535 560
536 # status line and headers 561 # status line and headers
537 $state{handle}->push_read (line => $qr_nlnl, sub { 562 $state{handle}->push_read (line => $qr_nlnl, sub {
563 my $keepalive = pop;
564
538 for ("$_[1]") { 565 for ("$_[1]") {
539 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 566 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
540 567
541 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc 568 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
542 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo })); 569 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
543 570
544 push @pseudo, 571 push @pseudo,
545 HTTPVersion => $1, 572 HTTPVersion => $1,
546 Status => $2, 573 Status => $2,
547 Reason => $3, 574 Reason => $3,
548 ; 575 ;
549 576
550 # things seen, not parsed: 577 my $hdr = parse_hdr
551 # p3pP="NON CUR OTPi OUR NOR UNI"
552
553 $hdr{lc $1} .= ",$2"
554 while /\G
555 ([^:\000-\037]*):
556 [\011\040]*
557 ((?: [^\012]+ | \012[\011\040] )*)
558 \012
559 /gxc;
560
561 /\G$/
562 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo })); 578 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
579
580 %hdr = (%$hdr, @pseudo);
581 }
582
583 # redirect handling
584 # microsoft and other shitheads don't give a shit for following standards,
585 # try to support some common forms of broken Location headers.
586 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
587 $hdr{location} =~ s/^\.\/+//;
588
589 my $url = "$rscheme://$uhost:$uport";
590
591 unless ($hdr{location} =~ s/^\///) {
592 $url .= $upath;
593 $url =~ s/\/[^\/]*$//;
563 } 594 }
564 595
565 # remove the "," prefix we added to all headers above
566 substr $_, 0, 1, ""
567 for values %hdr;
568
569 # patch in all pseudo headers
570 %hdr = (%hdr, @pseudo);
571
572 # redirect handling
573 # microsoft and other shitheads don't give a shit for following standards,
574 # try to support some common forms of broken Location headers.
575 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
576 $hdr{location} =~ s/^\.\/+//;
577
578 my $url = "$rscheme://$uhost:$uport";
579
580 unless ($hdr{location} =~ s/^\///) {
581 $url .= $upath;
582 $url =~ s/\/[^\/]*$//;
583 }
584
585 $hdr{location} = "$url/$hdr{location}"; 596 $hdr{location} = "$url/$hdr{location}";
597 }
598
599 my $redirect;
600
601 if ($recurse) {
602 my $status = $hdr{Status};
603
604 # industry standard is to redirect POST as GET for
605 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
606 # also, the UA should ask the user for 301 and 307 and POST,
607 # industry standard seems to be to simply follow.
608 # we go with the industry standard.
609 if ($status == 301 or $status == 302 or $status == 303) {
610 # HTTP/1.1 is unclear on how to mutate the method
611 $method = "GET" unless $method eq "HEAD";
612 $redirect = 1;
613 } elsif ($status == 307) {
614 $redirect = 1;
586 } 615 }
616 }
587 617
588 my $redirect; 618 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
619 $state{handle}->destroy if $state{handle};
620 %state = ();
589 621
622 if (defined $_[1]) {
623 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
624 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
625 }
626
627 # set-cookie processing
590 if ($recurse) { 628 if ($arg{cookie_jar}) {
591 my $status = $hdr{Status}; 629 for ($hdr{"set-cookie"}) {
630 # parse NAME=VALUE
631 my @kv;
592 632
593 # industry standard is to redirect POST as GET for 633 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
594 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
595 # also, the UA should ask the user for 301 and 307 and POST,
596 # industry standard seems to be to simply follow.
597 # we go with the industry standard.
598 if ($status == 301 or $status == 302 or $status == 303) {
599 # HTTP/1.1 is unclear on how to mutate the method
600 $method = "GET" unless $method eq "HEAD";
601 $redirect = 1; 634 my $name = $1;
602 } elsif ($status == 307) { 635 my $value = $3;
636
637 unless ($value) {
638 $value = $2;
639 $value =~ s/\\(.)/$1/gs;
640 }
641
642 push @kv, $name => $value;
643
644 last unless /\G\s*;/gc;
645 }
646
647 last unless @kv;
648
649 my $name = shift @kv;
650 my %kv = (value => shift @kv, @kv);
651
652 my $cdom;
653 my $cpath = (delete $kv{path}) || "/";
654
655 if (exists $kv{domain}) {
656 $cdom = delete $kv{domain};
657
658 $cdom =~ s/^\.?/./; # make sure it starts with a "."
659
660 next if $cdom =~ /\.$/;
661
662 # this is not rfc-like and not netscape-like. go figure.
663 my $ndots = $cdom =~ y/.//;
664 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
665 } else {
666 $cdom = $uhost;
667 }
668
603 $redirect = 1; 669 # store it
670 $arg{cookie_jar}{version} = 1;
671 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
672
673 redo if /\G\s*,/gc;
604 } 674 }
605 } 675 }
606 676
607 my $finish = sub {
608 $state{handle}->destroy if $state{handle};
609 %state = ();
610
611 # set-cookie processing
612 if ($arg{cookie_jar}) {
613 for ($_[1]{"set-cookie"}) {
614 # parse NAME=VALUE
615 my @kv;
616
617 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
618 my $name = $1;
619 my $value = $3;
620
621 unless ($value) {
622 $value = $2;
623 $value =~ s/\\(.)/$1/gs;
624 }
625
626 push @kv, $name => $value;
627
628 last unless /\G\s*;/gc;
629 }
630
631 last unless @kv;
632
633 my $name = shift @kv;
634 my %kv = (value => shift @kv, @kv);
635
636 my $cdom;
637 my $cpath = (delete $kv{path}) || "/";
638
639 if (exists $kv{domain}) {
640 $cdom = delete $kv{domain};
641
642 $cdom =~ s/^\.?/./; # make sure it starts with a "."
643
644 next if $cdom =~ /\.$/;
645
646 # this is not rfc-like and not netscape-like. go figure.
647 my $ndots = $cdom =~ y/.//;
648 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
649 } else {
650 $cdom = $uhost;
651 }
652
653 # store it
654 $arg{cookie_jar}{version} = 1;
655 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
656
657 redo if /\G\s*,/gc;
658 }
659 }
660
661 if ($redirect && exists $hdr{location}) { 677 if ($redirect && exists $hdr{location}) {
662 # we ignore any errors, as it is very common to receive 678 # we ignore any errors, as it is very common to receive
663 # Content-Length != 0 but no actual body 679 # Content-Length != 0 but no actual body
664 # we also access %hdr, as $_[1] might be an erro 680 # we also access %hdr, as $_[1] might be an erro
665 http_request ( 681 http_request (
666 $method => $hdr{location}, 682 $method => $hdr{location},
667 %arg, 683 %arg,
668 recurse => $recurse - 1, 684 recurse => $recurse - 1,
669 Redirect => \@_, 685 Redirect => [$_[0], \%hdr],
670 $cb); 686 $cb);
671 } else {
672 $cb->($_[0], $_[1]);
673 }
674 };
675
676 my $len = $hdr{"content-length"};
677
678 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
679 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
680 } elsif (
681 $hdr{Status} =~ /^(?:1..|[23]04)$/
682 or $method eq "HEAD"
683 or (defined $len && !$len)
684 ) {
685 # no body
686 $finish->("", \%hdr);
687 } else { 687 } else {
688 $cb->($_[0], \%hdr);
689 }
690 };
691
692 my $len = $hdr{"content-length"};
693
694 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
695 $finish->(undef, 598 => "Request cancelled by on_header");
696 } elsif (
697 $hdr{Status} =~ /^(?:1..|204|205|304)$/
698 or $method eq "HEAD"
699 or (defined $len && !$len)
700 ) {
701 # no body
702 $finish->("", undef, undef, 1);
703 } else {
688 # body handling, four different code paths 704 # body handling, many different code paths
689 # for want_body_handle, on_body (2x), normal (2x) 705 # - no body expected
690 # we might read too much here, but it does not matter yet (no pers. connections) 706 # - want_body_handle
707 # - te chunked
708 # - 2x length known (with or without on_body)
709 # - 2x length not known (with or without on_body)
691 if (!$redirect && $arg{want_body_handle}) { 710 if (!$redirect && $arg{want_body_handle}) {
692 $_[0]->on_eof (undef); 711 $_[0]->on_eof (undef);
693 $_[0]->on_error (undef); 712 $_[0]->on_error (undef);
694 $_[0]->on_read (undef); 713 $_[0]->on_read (undef);
695 714
696 $finish->(delete $state{handle}, \%hdr); 715 $finish->(delete $state{handle});
697 716
698 } elsif ($arg{on_body}) { 717 } elsif ($hdr{"transfer-encoding"} =~ /chunked/) {
718 my $body = undef;
719 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
720
699 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) }); 721 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
722
723 my $read_chunk; $read_chunk = sub {
724 warn $_[1];#d#
725 $_[1] =~ /^([0-9a-fA-F]+)/
726 or $finish->(undef, 599 => "Garbled chunked transfer encoding");
727
728 my $len = hex $1;
729
700 if ($len) { 730 if ($len) {
701 $_[0]->on_eof (undef); 731 $_[0]->push_read (chunk => hex $1, sub {
732 $on_body->($_[1], \%hdr)
733 or return $finish->(undef, 598 => "Request cancelled by on_body");
734
702 $_[0]->on_read (sub { 735 $_[0]->push_read (line => sub {
703 $len -= length $_[0]{rbuf}; 736 length $_[1]
704 737 and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
705 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 738 $_[0]->push_read (line => $read_chunk);
706 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
707
708 $len > 0 739 });
709 or $finish->("", \%hdr);
710 }); 740 });
711 } else { 741 } else {
712 $_[0]->on_eof (sub { 742 $_[0]->push_read (line => $qr_nlnl, sub {
713 $finish->("", \%hdr); 743 if (length $_[1]) {
744 for ("$_[1]") {
745 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
746
747 my $hdr = parse_hdr
748 or return $finish->(undef, 599 => "Garbled response trailers");
749
750 %hdr = (%hdr, %$hdr);
751 }
714 }); 752 }
715 $_[0]->on_read (sub { 753
716 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 754 $finish->($body, undef, undef, 1);
717 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
718 }); 755 });
719 } 756 }
757 };
758
759 $_[0]->push_read (line => $read_chunk);
760
761 } elsif ($arg{on_body}) {
762 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
763
764 if ($len) {
765 $_[0]->on_read (sub {
766 $len -= length $_[0]{rbuf};
767
768 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
769 or return $finish->(undef, 598 => "Request cancelled by on_body");
770
771 $len > 0
772 or $finish->("", undef, undef, 1);
773 });
720 } else { 774 } else {
721 $_[0]->on_eof (undef); 775 $_[0]->on_eof (sub {
722 776 $finish->("");
723 if ($len) { 777 });
724 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
725 $_[0]->on_read (sub { 778 $_[0]->on_read (sub {
779 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
780 or $finish->(undef, 598 => "Request cancelled by on_body");
781 });
782 }
783 } else {
784 $_[0]->on_eof (undef);
785
786 if ($len) {
787 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
788 $_[0]->on_read (sub {
726 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 789 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
727 if $len <= length $_[0]{rbuf}; 790 if $len <= length $_[0]{rbuf};
728 }); 791 });
729 } else { 792 } else {
730 $_[0]->on_error (sub { 793 $_[0]->on_error (sub {
731 ($! == Errno::EPIPE || !$!) 794 ($! == Errno::EPIPE || !$!)
732 ? $finish->(delete $_[0]{rbuf}, \%hdr) 795 ? $finish->(delete $_[0]{rbuf})
733 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }); 796 : $finish->(undef, 599 => $_[2]);
734 }); 797 });
735 $_[0]->on_read (sub { }); 798 $_[0]->on_read (sub { });
736 }
737 } 799 }
738 } 800 }
739 }); 801 }
740 }; 802 });
803 };
741 804
742 # now handle proxy-CONNECT method 805 # now handle proxy-CONNECT method
743 if ($proxy && $uscheme eq "https") { 806 if ($proxy && $uscheme eq "https") {
744 # oh dear, we have to wrap it into a connect request 807 # oh dear, we have to wrap it into a connect request
745 808
746 # maybe re-use $uauthority with patched port? 809 # maybe re-use $uauthority with patched port?
747 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 810 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
748 $state{handle}->push_read (line => $qr_nlnl, sub { 811 $state{handle}->push_read (line => $qr_nlnl, sub {
749 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 812 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
750 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo })); 813 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
751 814
752 if ($2 == 200) { 815 if ($2 == 200) {
753 $rpath = $upath; 816 $rpath = $upath;
754 &$handle_actual_request; 817 &$handle_actual_request;
755 } else { 818 } else {
756 %state = (); 819 %state = ();
757 $cb->(undef, { Status => $2, Reason => $3, @pseudo }); 820 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
758 }
759 }); 821 }
822 });
760 } else { 823 } else {
761 &$handle_actual_request; 824 &$handle_actual_request;
762 }
763
764 }, 825 }
765 $arg{on_prepare} || sub { $timeout }
766 ); 826 };
827
828 my $tcp_connect = $arg{tcp_connect}
829 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
830
831 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
832
767 }; 833 };
768 834
769 defined wantarray && AnyEvent::Util::guard { %state = () } 835 defined wantarray && AnyEvent::Util::guard { %state = () }
770} 836}
771 837

Diff Legend

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