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.56 by root, Mon Sep 6 05:30:54 2010 UTC vs.
Revision 1.57 by root, Mon Sep 6 06:31:32 2010 UTC

… …
48use AnyEvent::Socket (); 48use AnyEvent::Socket ();
49use AnyEvent::Handle (); 49use AnyEvent::Handle ();
50 50
51use base Exporter::; 51use base Exporter::;
52 52
53our $VERSION = '1.45'; 53our $VERSION = '1.46';
54 54
55our @EXPORT = qw(http_get http_post http_head http_request); 55our @EXPORT = qw(http_get http_post http_head http_request);
56 56
57our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 57our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
58our $MAX_RECURSE = 10; 58our $MAX_RECURSE = 10;
… …
338 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 338 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
339 339
340 _slot_schedule $_[0]; 340 _slot_schedule $_[0];
341} 341}
342 342
343our $qr_nl = qr{\015?\012};
344our $qr_nlnl = qr{(?<![^\012])\015?\012}; 343our $qr_nlnl = qr{(?<![^\012])\015?\012};
345 344
346our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 345our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
347our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 346our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
348 347
… …
515 # return if error occured during push_write() 514 # return if error occured during push_write()
516 return unless %state; 515 return unless %state;
517 516
518 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use 517 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
519 518
520 # status line 519 # status line and headers
521 $state{handle}->push_read (line => $qr_nl, sub { 520 $state{handle}->push_read (line => $qr_nlnl, sub {
522 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
523 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", @pseudo }));
524
525 push @pseudo,
526 HTTPVersion => $1,
527 Status => $2,
528 Reason => $3,
529 ;
530
531 # headers, could be optimized a bit
532 $state{handle}->unshift_read (line => $qr_nlnl, sub {
533 for ("$_[1]") { 521 for ("$_[1]") {
534 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 522 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
535 523
524 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc
525 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo }));
526
527 push @pseudo,
528 HTTPVersion => $1,
529 Status => $2,
530 Reason => $3,
531 ;
532
536 # things seen, not parsed: 533 # things seen, not parsed:
537 # p3pP="NON CUR OTPi OUR NOR UNI" 534 # p3pP="NON CUR OTPi OUR NOR UNI"
538 535
539 $hdr{lc $1} .= ",$2" 536 $hdr{lc $1} .= ",$2"
540 while /\G 537 while /\G
541 ([^:\000-\037]*): 538 ([^:\000-\037]*):
542 [\011\040]* 539 [\011\040]*
543 ((?: [^\012]+ | \012[\011\040] )*) 540 ((?: [^\012]+ | \012[\011\040] )*)
544 \012 541 \012
545 /gxc; 542 /gxc;
546 543
547 /\G$/ 544 /\G$/
548 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo })); 545 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo }));
546 }
547
548 # remove the "," prefix we added to all headers above
549 substr $_, 0, 1, ""
550 for values %hdr;
551
552 # patch in all pseudo headers
553 %hdr = (%hdr, @pseudo);
554
555 # redirect handling
556 # microsoft and other shitheads don't give a shit for following standards,
557 # try to support some common forms of broken Location headers.
558 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
559 $hdr{location} =~ s/^\.\/+//;
560
561 my $url = "$rscheme://$uhost:$uport";
562
563 unless ($hdr{location} =~ s/^\///) {
564 $url .= $upath;
565 $url =~ s/\/[^\/]*$//;
549 } 566 }
550 567
551 # remove the "," prefix we added to all headers above
552 substr $_, 0, 1, ""
553 for values %hdr;
554
555 # patch in all pseudo headers
556 %hdr = (%hdr, @pseudo);
557
558 # redirect handling
559 # microsoft and other shitheads don't give a shit for following standards,
560 # try to support some common forms of broken Location headers.
561 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
562 $hdr{location} =~ s/^\.\/+//;
563
564 my $url = "$rscheme://$uhost:$uport";
565
566 unless ($hdr{location} =~ s/^\///) {
567 $url .= $upath;
568 $url =~ s/\/[^\/]*$//;
569 }
570
571 $hdr{location} = "$url/$hdr{location}"; 568 $hdr{location} = "$url/$hdr{location}";
569 }
570
571 my $redirect;
572
573 if ($recurse) {
574 my $status = $hdr{Status};
575
576 # industry standard is to redirect POST as GET for
577 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
578 # also, the UA should ask the user for 301 and 307 and POST,
579 # industry standard seems to be to simply follow.
580 # we go with the industry standard.
581 if ($status == 301 or $status == 302 or $status == 303) {
582 # HTTP/1.1 is unclear on how to mutate the method
583 $method = "GET" unless $method eq "HEAD";
584 $redirect = 1;
585 } elsif ($status == 307) {
586 $redirect = 1;
572 } 587 }
588 }
573 589
574 my $redirect; 590 my $finish = sub {
591 $state{handle}->destroy if $state{handle};
592 %state = ();
575 593
594 # set-cookie processing
576 if ($recurse) { 595 if ($arg{cookie_jar}) {
577 my $status = $hdr{Status}; 596 for ($_[1]{"set-cookie"}) {
597 # parse NAME=VALUE
598 my @kv;
578 599
579 if (($status == 301 || $status == 302) && $method ne "POST") { 600 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
580 # apparently, mozilla et al. just change POST to GET here
581 # more research is needed before we do the same
582 $redirect = 1; 601 my $name = $1;
583 } elsif ($status == 303) { 602 my $value = $3;
584 # even http/1.1 is unclear on how to mutate the method 603
585 $method = "GET" unless $method eq "HEAD"; 604 unless ($value) {
605 $value = $2;
606 $value =~ s/\\(.)/$1/gs;
607 }
608
609 push @kv, $name => $value;
610
611 last unless /\G\s*;/gc;
612 }
613
614 last unless @kv;
615
616 my $name = shift @kv;
617 my %kv = (value => shift @kv, @kv);
618
619 my $cdom;
620 my $cpath = (delete $kv{path}) || "/";
621
622 if (exists $kv{domain}) {
623 $cdom = delete $kv{domain};
624
625 $cdom =~ s/^\.?/./; # make sure it starts with a "."
626
627 next if $cdom =~ /\.$/;
628
629 # this is not rfc-like and not netscape-like. go figure.
630 my $ndots = $cdom =~ y/.//;
631 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
632 } else {
633 $cdom = $uhost;
634 }
635
586 $redirect = 1; 636 # store it
587 } elsif ($status == 307 && $method =~ /^(?:GET|HEAD)$/) { 637 $arg{cookie_jar}{version} = 1;
588 $redirect = 1; 638 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
639
640 redo if /\G\s*,/gc;
589 } 641 }
590 } 642 }
591 643
592 my $finish = sub { 644 if ($redirect && exists $hdr{location}) {
593 $state{handle}->destroy if $state{handle}; 645 # we ignore any errors, as it is very common to receive
594 %state = (); 646 # Content-Length != 0 but no actual body
595 647 # we also access %hdr, as $_[1] might be an erro
596 # set-cookie processing 648 http_request (
597 if ($arg{cookie_jar}) { 649 $method => $hdr{location},
598 for ($_[1]{"set-cookie"}) {
599 # parse NAME=VALUE
600 my @kv;
601
602 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
603 my $name = $1;
604 my $value = $3;
605
606 unless ($value) {
607 $value = $2;
608 $value =~ s/\\(.)/$1/gs;
609 } 650 %arg,
651 recurse => $recurse - 1,
652 Redirect => \@_,
653 $cb);
654 } else {
655 $cb->($_[0], $_[1]);
656 }
657 };
610 658
611 push @kv, $name => $value; 659 my $len = $hdr{"content-length"};
612 660
613 last unless /\G\s*;/gc; 661 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
662 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
663 } elsif (
664 $hdr{Status} =~ /^(?:1..|[23]04)$/
665 or $method eq "HEAD"
666 or (defined $len && !$len)
667 ) {
668 # no body
669 $finish->("", \%hdr);
670 } else {
671 # body handling, four different code paths
672 # for want_body_handle, on_body (2x), normal (2x)
673 # we might read too much here, but it does not matter yet (no pers. connections)
674 if (!$redirect && $arg{want_body_handle}) {
675 $_[0]->on_eof (undef);
676 $_[0]->on_error (undef);
677 $_[0]->on_read (undef);
678
679 $finish->(delete $state{handle}, \%hdr);
680
681 } elsif ($arg{on_body}) {
682 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
683 if ($len) {
684 $_[0]->on_eof (undef);
685 $_[0]->on_read (sub {
686 $len -= length $_[0]{rbuf};
687
688 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
689 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
690
614 } 691 $len > 0
615 692 or $finish->("", \%hdr);
616 last unless @kv;
617
618 my $name = shift @kv;
619 my %kv = (value => shift @kv, @kv);
620
621 my $cdom;
622 my $cpath = (delete $kv{path}) || "/";
623
624 if (exists $kv{domain}) {
625 $cdom = delete $kv{domain};
626
627 $cdom =~ s/^\.?/./; # make sure it starts with a "."
628
629 next if $cdom =~ /\.$/;
630
631 # this is not rfc-like and not netscape-like. go figure.
632 my $ndots = $cdom =~ y/.//;
633 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
634 } else {
635 $cdom = $uhost;
636 }
637
638 # store it
639 $arg{cookie_jar}{version} = 1;
640 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
641
642 redo if /\G\s*,/gc;
643 } 693 });
694 } else {
695 $_[0]->on_eof (sub {
696 $finish->("", \%hdr);
697 });
698 $_[0]->on_read (sub {
699 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
700 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
701 });
644 } 702 }
703 } else {
704 $_[0]->on_eof (undef);
645 705
646 if ($redirect && exists $hdr{location}) { 706 if ($len) {
647 # we ignore any errors, as it is very common to receive 707 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
648 # Content-Length != 0 but no actual body 708 $_[0]->on_read (sub {
649 # we also access %hdr, as $_[1] might be an erro 709 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
650 http_request ( 710 if $len <= length $_[0]{rbuf};
651 $method => $hdr{location},
652 %arg,
653 recurse => $recurse - 1,
654 Redirect => \@_,
655 $cb); 711 });
656 } else { 712 } else {
657 $cb->($_[0], $_[1]);
658 }
659 };
660
661 my $len = $hdr{"content-length"};
662
663 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
664 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
665 } elsif (
666 $hdr{Status} =~ /^(?:1..|[23]04)$/
667 or $method eq "HEAD"
668 or (defined $len && !$len)
669 ) {
670 # no body
671 $finish->("", \%hdr);
672 } else {
673 # body handling, four different code paths
674 # for want_body_handle, on_body (2x), normal (2x)
675 # we might read too much here, but it does not matter yet (no pers. connections)
676 if (!$redirect && $arg{want_body_handle}) {
677 $_[0]->on_eof (undef);
678 $_[0]->on_error (undef);
679 $_[0]->on_read (undef);
680
681 $finish->(delete $state{handle}, \%hdr);
682
683 } elsif ($arg{on_body}) {
684 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
685 if ($len) {
686 $_[0]->on_eof (undef);
687 $_[0]->on_read (sub {
688 $len -= length $_[0]{rbuf};
689
690 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
691 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
692
693 $len > 0
694 or $finish->("", \%hdr);
695 });
696 } else {
697 $_[0]->on_eof (sub {
698 $finish->("", \%hdr);
699 });
700 $_[0]->on_read (sub {
701 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
702 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
703 });
704 }
705 } else {
706 $_[0]->on_eof (undef);
707
708 if ($len) {
709 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
710 $_[0]->on_read (sub {
711 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
712 if $len <= length $_[0]{rbuf};
713 });
714 } else {
715 $_[0]->on_error (sub { 713 $_[0]->on_error (sub {
716 $! == Errno::EPIPE || !$! 714 ($! == Errno::EPIPE || !$!)
717 ? $finish->(delete $_[0]{rbuf}, \%hdr) 715 ? $finish->(delete $_[0]{rbuf}, \%hdr)
718 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }); 716 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo });
719 }); 717 });
720 $_[0]->on_read (sub { }); 718 $_[0]->on_read (sub { });
721 }
722 } 719 }
723 } 720 }
724 }); 721 }
725 }); 722 });
726 }; 723 };
727 724
728 # now handle proxy-CONNECT method 725 # now handle proxy-CONNECT method
729 if ($proxy && $uscheme eq "https") { 726 if ($proxy && $uscheme eq "https") {

Diff Legend

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