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.54 by root, Wed Jun 16 18:09:52 2010 UTC vs.
Revision 1.55 by root, Wed Jun 16 19:17:30 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.44'; 53our $VERSION = '1.45';
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;
… …
99The callback will be called with the response body data as first argument 99The callback will be called with the response body data as first argument
100(or C<undef> if an error occured), and a hash-ref with response headers as 100(or C<undef> if an error occured), and a hash-ref with response headers as
101second argument. 101second argument.
102 102
103All the headers in that hash are lowercased. In addition to the response 103All the headers in that hash are lowercased. In addition to the response
104headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason> 104headers, the "pseudo-headers" (uppercase to avoid clashing with possible
105response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
105contain the three parts of the HTTP Status-Line of the same name. The 106three parts of the HTTP Status-Line of the same name.
107
106pseudo-header C<URL> contains the original URL (which can differ from the 108The pseudo-header C<URL> contains the actual URL (which can differ from
107requested URL when following redirects). 109the requested URL when following redirects - for example, you might get
110an error that your URL scheme is not supported even though your URL is a
111valid http URL because it redirected to an ftp URL, in which case you can
112look at the URL pseudo header).
113
114The pseudo-header C<Redirect> only exists when the request was a result
115of an internal redirect. In that case it is an array reference with
116the C<($data, $headers)> from the redirect response. Note that this
117response could in turn be the result of a redirect itself, and C<<
118$headers->{Redirect}[1]{Redirect} >> will then contain the original
119response, and so on.
108 120
109If the server sends a header multiple times, then their contents will be 121If the server sends a header multiple times, then their contents will be
110joined together with a comma (C<,>), as per the HTTP spec. 122joined together with a comma (C<,>), as per the HTTP spec.
111 123
112If an internal error occurs, such as not being able to resolve a hostname, 124If an internal error occurs, such as not being able to resolve a hostname,
… …
349 while (my ($k, $v) = each %$hdr) { 361 while (my ($k, $v) = each %$hdr) {
350 $hdr{lc $k} = $v; 362 $hdr{lc $k} = $v;
351 } 363 }
352 } 364 }
353 365
366 # pseudo headers for all subsequent responses
367 my @pseudo = (URL => $url);
368 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
369
354 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 370 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
355 371
356 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url }) 372 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo })
357 if $recurse < 0; 373 if $recurse < 0;
358 374
359 my $proxy = $arg{proxy} || $PROXY; 375 my $proxy = $arg{proxy} || $PROXY;
360 my $timeout = $arg{timeout} || $TIMEOUT; 376 my $timeout = $arg{timeout} || $TIMEOUT;
361 377
… …
364 380
365 $uscheme = lc $uscheme; 381 $uscheme = lc $uscheme;
366 382
367 my $uport = $uscheme eq "http" ? 80 383 my $uport = $uscheme eq "http" ? 80
368 : $uscheme eq "https" ? 443 384 : $uscheme eq "https" ? 443
369 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", URL => $url }); 385 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo });
370 386
371 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 387 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
372 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url }); 388 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo });
373 389
374 my $uhost = $1; 390 my $uhost = $1;
375 $uport = $2 if defined $2; 391 $uport = $2 if defined $2;
376 392
377 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost" 393 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
… …
444 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 460 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
445 $state{fh} = shift 461 $state{fh} = shift
446 or do { 462 or do {
447 my $err = "$!"; 463 my $err = "$!";
448 %state = (); 464 %state = ();
449 return $cb->(undef, { Status => 599, Reason => $err, URL => $url }); 465 return $cb->(undef, { Status => 599, Reason => $err, @pseudo });
450 }; 466 };
451 467
452 pop; # free memory, save a tree 468 pop; # free memory, save a tree
453 469
454 return unless delete $state{connect_guard}; 470 return unless delete $state{connect_guard};
… …
473 } 489 }
474 490
475 # (re-)configure handle 491 # (re-)configure handle
476 $state{handle}->on_error (sub { 492 $state{handle}->on_error (sub {
477 %state = (); 493 %state = ();
478 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url }); 494 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo });
479 }); 495 });
480 $state{handle}->on_eof (sub { 496 $state{handle}->on_eof (sub {
481 %state = (); 497 %state = ();
482 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url }); 498 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo });
483 }); 499 });
484 500
485 $state{handle}->starttls ("connect") if $rscheme eq "https"; 501 $state{handle}->starttls ("connect") if $rscheme eq "https";
486 502
487 # handle actual, non-tunneled, request 503 # handle actual, non-tunneled, request
… …
497 ); 513 );
498 514
499 # return if error occured during push_write() 515 # return if error occured during push_write()
500 return unless %state; 516 return unless %state;
501 517
502 %hdr = (); # reduce memory usage, save a kitten 518 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
503 519
504 # status line 520 # status line
505 $state{handle}->push_read (line => $qr_nl, sub { 521 $state{handle}->push_read (line => $qr_nl, sub {
506 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 522 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
507 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url })); 523 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", @pseudo }));
508 524
509 my %hdr = ( # response headers 525 push @pseudo,
510 HTTPVersion => ",$1", 526 HTTPVersion => $1,
511 Status => ",$2", 527 Status => $2,
512 Reason => ",$3", 528 Reason => $3,
513 URL => ",$url"
514 ); 529 ;
515 530
516 # headers, could be optimized a bit 531 # headers, could be optimized a bit
517 $state{handle}->unshift_read (line => $qr_nlnl, sub { 532 $state{handle}->unshift_read (line => $qr_nlnl, sub {
518 for ("$_[1]") { 533 for ("$_[1]") {
519 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 534 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
… …
528 ((?: [^\012]+ | \012[\011\040] )*) 543 ((?: [^\012]+ | \012[\011\040] )*)
529 \012 544 \012
530 /gxc; 545 /gxc;
531 546
532 /\G$/ 547 /\G$/
533 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url })); 548 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo }));
534 } 549 }
535 550
551 # remove the "," prefix we added to all headers above
536 substr $_, 0, 1, "" 552 substr $_, 0, 1, ""
537 for values %hdr; 553 for values %hdr;
554
555 # patch in all pseudo headers
556 %hdr = (%hdr, @pseudo);
538 557
539 # redirect handling 558 # redirect handling
540 # microsoft and other shitheads don't give a shit for following standards, 559 # microsoft and other shitheads don't give a shit for following standards,
541 # try to support some common forms of broken Location headers. 560 # try to support some common forms of broken Location headers.
542 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { 561 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
… …
553 } 572 }
554 573
555 my $redirect; 574 my $redirect;
556 575
557 if ($recurse) { 576 if ($recurse) {
577 my $status = $hdr{Status};
578
558 if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") { 579 if (($status == 301 || $status == 302) && $method ne "POST") {
559 # apparently, mozilla et al. just change POST to GET here 580 # apparently, mozilla et al. just change POST to GET here
560 # more research is needed before we do the same 581 # more research is needed before we do the same
561 $redirect = 1; 582 $redirect = 1;
562 } elsif ($hdr{Status} == 303) { 583 } elsif ($status == 303) {
563 # even http/1.1 is unclear on how to mutate the method 584 # even http/1.1 is unclear on how to mutate the method
564 $method = "GET" unless $method eq "HEAD"; 585 $method = "GET" unless $method eq "HEAD";
565 $redirect = 1; 586 $redirect = 1;
566 } elsif ($hdr{Status} == 307 && $method =~ /^(?:GET|HEAD)$/) { 587 } elsif ($status == 307 && $method =~ /^(?:GET|HEAD)$/) {
567 $redirect = 1; 588 $redirect = 1;
568 } 589 }
569 } 590 }
570 591
571 my $finish = sub { 592 my $finish = sub {
… …
624 645
625 if ($redirect && exists $hdr{location}) { 646 if ($redirect && exists $hdr{location}) {
626 # we ignore any errors, as it is very common to receive 647 # we ignore any errors, as it is very common to receive
627 # Content-Length != 0 but no actual body 648 # Content-Length != 0 but no actual body
628 # we also access %hdr, as $_[1] might be an erro 649 # we also access %hdr, as $_[1] might be an erro
629 http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb); 650 http_request (
651 $method => $hdr{location},
652 %arg,
653 recurse => $recurse - 1,
654 Redirect => \@_,
655 $cb);
630 } else { 656 } else {
631 $cb->($_[0], $_[1]); 657 $cb->($_[0], $_[1]);
632 } 658 }
633 }; 659 };
634 660
635 my $len = $hdr{"content-length"}; 661 my $len = $hdr{"content-length"};
636 662
637 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { 663 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
638 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url }); 664 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
639 } elsif ( 665 } elsif (
640 $hdr{Status} =~ /^(?:1..|[23]04)$/ 666 $hdr{Status} =~ /^(?:1..|[23]04)$/
641 or $method eq "HEAD" 667 or $method eq "HEAD"
642 or (defined $len && !$len) 668 or (defined $len && !$len)
643 ) { 669 ) {
… …
653 $_[0]->on_read (undef); 679 $_[0]->on_read (undef);
654 680
655 $finish->(delete $state{handle}, \%hdr); 681 $finish->(delete $state{handle}, \%hdr);
656 682
657 } elsif ($arg{on_body}) { 683 } elsif ($arg{on_body}) {
658 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) }); 684 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
659 if ($len) { 685 if ($len) {
660 $_[0]->on_eof (undef); 686 $_[0]->on_eof (undef);
661 $_[0]->on_read (sub { 687 $_[0]->on_read (sub {
662 $len -= length $_[0]{rbuf}; 688 $len -= length $_[0]{rbuf};
663 689
664 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 690 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
665 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url }); 691 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
666 692
667 $len > 0 693 $len > 0
668 or $finish->("", \%hdr); 694 or $finish->("", \%hdr);
669 }); 695 });
670 } else { 696 } else {
671 $_[0]->on_eof (sub { 697 $_[0]->on_eof (sub {
672 $finish->("", \%hdr); 698 $finish->("", \%hdr);
673 }); 699 });
674 $_[0]->on_read (sub { 700 $_[0]->on_read (sub {
675 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 701 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
676 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url }); 702 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
677 }); 703 });
678 } 704 }
679 } else { 705 } else {
680 $_[0]->on_eof (undef); 706 $_[0]->on_eof (undef);
681 707
682 if ($len) { 708 if ($len) {
683 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) }); 709 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
684 $_[0]->on_read (sub { 710 $_[0]->on_read (sub {
685 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 711 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
686 if $len <= length $_[0]{rbuf}; 712 if $len <= length $_[0]{rbuf};
687 }); 713 });
688 } else { 714 } else {
689 $_[0]->on_error (sub { 715 $_[0]->on_error (sub {
690 $! == Errno::EPIPE || !$! 716 $! == Errno::EPIPE || !$!
691 ? $finish->(delete $_[0]{rbuf}, \%hdr) 717 ? $finish->(delete $_[0]{rbuf}, \%hdr)
692 : $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }); 718 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo });
693 }); 719 });
694 $_[0]->on_read (sub { }); 720 $_[0]->on_read (sub { });
695 } 721 }
696 } 722 }
697 } 723 }
… …
705 731
706 # maybe re-use $uauthority with patched port? 732 # maybe re-use $uauthority with patched port?
707 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 733 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
708 $state{handle}->push_read (line => $qr_nlnl, sub { 734 $state{handle}->push_read (line => $qr_nlnl, sub {
709 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 735 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
710 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", URL => $url })); 736 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo }));
711 737
712 if ($2 == 200) { 738 if ($2 == 200) {
713 $rpath = $upath; 739 $rpath = $upath;
714 &$handle_actual_request; 740 &$handle_actual_request;
715 } else { 741 } else {
716 %state = (); 742 %state = ();
717 $cb->(undef, { Status => $2, Reason => $3, URL => $url }); 743 $cb->(undef, { Status => $2, Reason => $3, @pseudo });
718 } 744 }
719 }); 745 });
720 } else { 746 } else {
721 &$handle_actual_request; 747 &$handle_actual_request;
722 } 748 }
… …
742 unshift @_, "POST", $url, "body"; 768 unshift @_, "POST", $url, "body";
743 &http_request 769 &http_request
744} 770}
745 771
746=back 772=back
773
774=head2 DNS CACHING
775
776AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
777the actual connection, which in turn uses AnyEvent::DNS to resolve
778hostnames. The latter is a simple stub resolver and does no caching
779on its own. If you want DNS caching, you currently have to provide
780your own default resolver (by storing a suitable resolver object in
781C<$AnyEvent::DNS::RESOLVER>).
747 782
748=head2 GLOBAL FUNCTIONS AND VARIABLES 783=head2 GLOBAL FUNCTIONS AND VARIABLES
749 784
750=over 4 785=over 4
751 786

Diff Legend

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