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.67 by root, Fri Dec 31 06:18:54 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
… …
351 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 352 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
352 353
353 _slot_schedule $_[0]; 354 _slot_schedule $_[0];
354} 355}
355 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
356our $qr_nlnl = qr{(?<![^\012])\015?\012}; 382our $qr_nlnl = qr{(?<![^\012])\015?\012};
357 383
358our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 384our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
359our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 385our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
360 386
… …
379 my @pseudo = (URL => $url); 405 my @pseudo = (URL => $url);
380 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect}; 406 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
381 407
382 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 408 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
383 409
384 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo }) 410 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
385 if $recurse < 0; 411 if $recurse < 0;
386 412
387 my $proxy = $arg{proxy} || $PROXY; 413 my $proxy = $arg{proxy} || $PROXY;
388 my $timeout = $arg{timeout} || $TIMEOUT; 414 my $timeout = $arg{timeout} || $TIMEOUT;
389 415
… …
392 418
393 $uscheme = lc $uscheme; 419 $uscheme = lc $uscheme;
394 420
395 my $uport = $uscheme eq "http" ? 80 421 my $uport = $uscheme eq "http" ? 80
396 : $uscheme eq "https" ? 443 422 : $uscheme eq "https" ? 443
397 : 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" });
398 424
399 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 425 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
400 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo }); 426 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
401 427
402 my $uhost = $1; 428 my $uhost = $1;
403 $uport = $2 if defined $2; 429 $uport = $2 if defined $2;
404 430
405 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost" 431 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
… …
454 } else { 480 } else {
455 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 481 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
456 } 482 }
457 483
458 # leave out fragment and query string, just a heuristic 484 # leave out fragment and query string, just a heuristic
459 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; 485 $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
460 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; 486 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
461 487
462 $hdr{"content-length"} = length $arg{body} 488 $hdr{"content-length"} = length $arg{body}
463 if length $arg{body} || $method ne "GET"; 489 if length $arg{body} || $method ne "GET";
464 490
491 $hdr{connection} = "close TE";
492 $hdr{te} = "trailers" unless exists $hdr{te};
493
465 my %state = (connect_guard => 1); 494 my %state = (connect_guard => 1);
466 495
467 _get_slot $uhost, sub { 496 _get_slot $uhost, sub {
468 $state{slot_guard} = shift; 497 $state{slot_guard} = shift;
469 498
470 return unless $state{connect_guard}; 499 return unless $state{connect_guard};
471 500
472 my $tcp_connect = $arg{tcp_connect} 501 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 502 $state{fh} = shift
480 or do { 503 or do {
481 my $err = "$!"; 504 my $err = "$!";
482 %state = (); 505 %state = ();
483 return $cb->(undef, { Status => 599, Reason => $err, @pseudo }); 506 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
484 }; 507 };
485 508
486 pop; # free memory, save a tree 509 pop; # free memory, save a tree
487 510
488 return unless delete $state{connect_guard}; 511 return unless delete $state{connect_guard};
489 512
490 # get handle 513 # get handle
491 $state{handle} = new AnyEvent::Handle 514 $state{handle} = new AnyEvent::Handle
492 fh => $state{fh}, 515 fh => $state{fh},
493 peername => $rhost, 516 peername => $rhost,
494 tls_ctx => $arg{tls_ctx}, 517 tls_ctx => $arg{tls_ctx},
495 # these need to be reconfigured on keepalive handles 518 # these need to be reconfigured on keepalive handles
496 timeout => $timeout, 519 timeout => $timeout,
497 on_error => sub { 520 on_error => sub {
498 %state = (); 521 %state = ();
499 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo }); 522 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
500 }, 523 },
501 on_eof => sub { 524 on_eof => sub {
502 %state = (); 525 %state = ();
503 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo }); 526 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
504 }, 527 },
505 ; 528 ;
506 529
507 # limit the number of persistent connections 530 # limit the number of persistent connections
508 # keepalive not yet supported 531 # keepalive not yet supported
509# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 532# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
510# ++$KA_COUNT{$_[1]}; 533# ++$KA_COUNT{$_[1]};
511# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 534# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
512# --$KA_COUNT{$_[1]} 535# --$KA_COUNT{$_[1]}
513# }; 536# };
514# $hdr{connection} = "keep-alive"; 537# $hdr{connection} = "keep-alive";
515# } else { 538# } else {
516 delete $hdr{connection}; 539# delete $hdr{connection};
517# } 540# }
518 541
519 $state{handle}->starttls ("connect") if $rscheme eq "https"; 542 $state{handle}->starttls ("connect") if $rscheme eq "https";
520 543
521 # handle actual, non-tunneled, request 544 # handle actual, non-tunneled, request
522 my $handle_actual_request = sub { 545 my $handle_actual_request = sub {
523 $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};
524 547
525 # send request 548 # send request
526 $state{handle}->push_write ( 549 $state{handle}->push_write (
527 "$method $rpath HTTP/1.0\015\012" 550 "$method $rpath HTTP/1.1\015\012"
528 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 551 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
529 . "\015\012" 552 . "\015\012"
530 . (delete $arg{body}) 553 . (delete $arg{body})
531 ); 554 );
532 555
533 # return if error occured during push_write() 556 # return if error occured during push_write()
534 return unless %state; 557 return unless %state;
535 558
536 %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
537 560
538 # status line and headers 561 # status line and headers
539 $state{handle}->push_read (line => $qr_nlnl, sub { 562 $state{handle}->push_read (line => $qr_nlnl, sub {
563 my $keepalive = pop;
564
540 for ("$_[1]") { 565 for ("$_[1]") {
541 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.
542 567
543 /^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
544 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" }));
545 570
546 push @pseudo, 571 push @pseudo,
547 HTTPVersion => $1, 572 HTTPVersion => $1,
548 Status => $2, 573 Status => $2,
549 Reason => $3, 574 Reason => $3,
550 ; 575 ;
551 576
552 # things seen, not parsed: 577 my $hdr = parse_hdr
553 # p3pP="NON CUR OTPi OUR NOR UNI"
554
555 $hdr{lc $1} .= ",$2"
556 while /\G
557 ([^:\000-\037]*):
558 [\011\040]*
559 ((?: [^\012]+ | \012[\011\040] )*)
560 \012
561 /gxc;
562
563 /\G$/
564 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/\/[^\/]*$//;
565 } 594 }
566 595
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}"; 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;
588 } 615 }
616 }
589 617
590 my $redirect; 618 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
619 $state{handle}->destroy if $state{handle};
620 %state = ();
591 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
592 if ($recurse) { 628 if ($arg{cookie_jar}) {
593 my $status = $hdr{Status}; 629 for ($hdr{"set-cookie"}) {
630 # parse NAME=VALUE
631 my @kv;
594 632
595 # industry standard is to redirect POST as GET for 633 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; 634 my $name = $1;
604 } 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
605 $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;
606 } 674 }
607 } 675 }
608 676
609 my $finish = sub {
610 $state{handle}->destroy if $state{handle};
611 %state = ();
612
613 # set-cookie processing
614 if ($arg{cookie_jar}) {
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 }
627
628 push @kv, $name => $value;
629
630 last unless /\G\s*;/gc;
631 }
632
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 }
661 }
662
663 if ($redirect && exists $hdr{location}) { 677 if ($redirect && exists $hdr{location}) {
664 # we ignore any errors, as it is very common to receive 678 # we ignore any errors, as it is very common to receive
665 # Content-Length != 0 but no actual body 679 # Content-Length != 0 but no actual body
666 # we also access %hdr, as $_[1] might be an erro 680 # we also access %hdr, as $_[1] might be an erro
667 http_request ( 681 http_request (
668 $method => $hdr{location}, 682 $method => $hdr{location},
669 %arg, 683 %arg,
670 recurse => $recurse - 1, 684 recurse => $recurse - 1,
671 Redirect => \@_, 685 Redirect => [$_[0], \%hdr],
672 $cb); 686 $cb);
673 } 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 { 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 {
690 # body handling, four different code paths 704 # body handling, many different code paths
691 # for want_body_handle, on_body (2x), normal (2x) 705 # - no body expected
692 # 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)
693 if (!$redirect && $arg{want_body_handle}) { 710 if (!$redirect && $arg{want_body_handle}) {
694 $_[0]->on_eof (undef); 711 $_[0]->on_eof (undef);
695 $_[0]->on_error (undef); 712 $_[0]->on_error (undef);
696 $_[0]->on_read (undef); 713 $_[0]->on_read (undef);
697 714
698 $finish->(delete $state{handle}, \%hdr); 715 $finish->(delete $state{handle});
699 716
700 } 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
701 $_[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 $_[1] =~ /^([0-9a-fA-F]+)/
725 or $finish->(undef, 599 => "Garbled chunked transfer encoding");
726
727 my $len = hex $1;
728
702 if ($len) { 729 if ($len) {
703 $_[0]->on_eof (undef); 730 $_[0]->push_read (chunk => hex $1, sub {
731 $on_body->($_[1], \%hdr)
732 or return $finish->(undef, 598 => "Request cancelled by on_body");
733
704 $_[0]->on_read (sub { 734 $_[0]->push_read (line => sub {
705 $len -= length $_[0]{rbuf}; 735 length $_[1]
706 736 and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
707 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 737 $_[0]->push_read (line => $read_chunk);
708 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
709
710 $len > 0 738 });
711 or $finish->("", \%hdr);
712 }); 739 });
713 } else { 740 } else {
714 $_[0]->on_eof (sub { 741 $_[0]->push_read (line => $qr_nlnl, sub {
715 $finish->("", \%hdr); 742 if (length $_[1]) {
743 for ("$_[1]") {
744 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
745
746 my $hdr = parse_hdr
747 or return $finish->(undef, 599 => "Garbled response trailers");
748
749 %hdr = (%hdr, %$hdr);
750 }
716 }); 751 }
717 $_[0]->on_read (sub { 752
718 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 753 $finish->($body, undef, undef, 1);
719 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
720 }); 754 });
721 } 755 }
756 };
757
758 $_[0]->push_read (line => $read_chunk);
759
760 } elsif ($arg{on_body}) {
761 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
762
763 if ($len) {
764 $_[0]->on_read (sub {
765 $len -= length $_[0]{rbuf};
766
767 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
768 or return $finish->(undef, 598 => "Request cancelled by on_body");
769
770 $len > 0
771 or $finish->("", undef, undef, 1);
772 });
722 } else { 773 } else {
723 $_[0]->on_eof (undef); 774 $_[0]->on_eof (sub {
724 775 $finish->("");
725 if ($len) { 776 });
726 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
727 $_[0]->on_read (sub { 777 $_[0]->on_read (sub {
778 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
779 or $finish->(undef, 598 => "Request cancelled by on_body");
780 });
781 }
782 } else {
783 $_[0]->on_eof (undef);
784
785 if ($len) {
786 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
787 $_[0]->on_read (sub {
728 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 788 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
729 if $len <= length $_[0]{rbuf}; 789 if $len <= length $_[0]{rbuf};
730 }); 790 });
731 } else { 791 } else {
732 $_[0]->on_error (sub { 792 $_[0]->on_error (sub {
733 ($! == Errno::EPIPE || !$!) 793 ($! == Errno::EPIPE || !$!)
734 ? $finish->(delete $_[0]{rbuf}, \%hdr) 794 ? $finish->(delete $_[0]{rbuf})
735 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }); 795 : $finish->(undef, 599 => $_[2]);
736 }); 796 });
737 $_[0]->on_read (sub { }); 797 $_[0]->on_read (sub { });
738 }
739 } 798 }
740 } 799 }
741 }); 800 }
742 }; 801 });
802 };
743 803
744 # now handle proxy-CONNECT method 804 # now handle proxy-CONNECT method
745 if ($proxy && $uscheme eq "https") { 805 if ($proxy && $uscheme eq "https") {
746 # oh dear, we have to wrap it into a connect request 806 # oh dear, we have to wrap it into a connect request
747 807
748 # maybe re-use $uauthority with patched port? 808 # 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"); 809 $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 { 810 $state{handle}->push_read (line => $qr_nlnl, sub {
751 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 811 $_[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 })); 812 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
753 813
754 if ($2 == 200) { 814 if ($2 == 200) {
755 $rpath = $upath; 815 $rpath = $upath;
756 &$handle_actual_request; 816 &$handle_actual_request;
757 } else { 817 } else {
758 %state = (); 818 %state = ();
759 $cb->(undef, { Status => $2, Reason => $3, @pseudo }); 819 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
760 }
761 }); 820 }
821 });
762 } else { 822 } else {
763 &$handle_actual_request; 823 &$handle_actual_request;
764 }
765
766 }, 824 }
767 $arg{on_prepare} || sub { $timeout }
768 ); 825 };
826
827 my $tcp_connect = $arg{tcp_connect}
828 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
829
830 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
831
769 }; 832 };
770 833
771 defined wantarray && AnyEvent::Util::guard { %state = () } 834 defined wantarray && AnyEvent::Util::guard { %state = () }
772} 835}
773 836

Diff Legend

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