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.52 by root, Sat Sep 26 10:13:12 2009 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.43'; 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"
394 unless exists $hdr{host};
378 395
379 $uhost =~ s/^\[(.*)\]$/$1/; 396 $uhost =~ s/^\[(.*)\]$/$1/;
380 $upath .= "?$query" if length $query; 397 $upath .= "?$query" if length $query;
381 398
382 $upath =~ s%^/?%/%; 399 $upath =~ s%^/?%/%;
… …
428 445
429 # leave out fragment and query string, just a heuristic 446 # leave out fragment and query string, just a heuristic
430 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; 447 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer};
431 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; 448 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"};
432 449
433 $hdr{"content-length"} = length $arg{body}; 450 $hdr{"content-length"} = length $arg{body}
451 if length $arg{body} || $method ne "GET";
434 452
435 my %state = (connect_guard => 1); 453 my %state = (connect_guard => 1);
436 454
437 _get_slot $uhost, sub { 455 _get_slot $uhost, sub {
438 $state{slot_guard} = shift; 456 $state{slot_guard} = shift;
… …
442 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 460 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
443 $state{fh} = shift 461 $state{fh} = shift
444 or do { 462 or do {
445 my $err = "$!"; 463 my $err = "$!";
446 %state = (); 464 %state = ();
447 return $cb->(undef, { Status => 599, Reason => $err, URL => $url }); 465 return $cb->(undef, { Status => 599, Reason => $err, @pseudo });
448 }; 466 };
449 467
450 pop; # free memory, save a tree 468 pop; # free memory, save a tree
451 469
452 return unless delete $state{connect_guard}; 470 return unless delete $state{connect_guard};
… …
471 } 489 }
472 490
473 # (re-)configure handle 491 # (re-)configure handle
474 $state{handle}->on_error (sub { 492 $state{handle}->on_error (sub {
475 %state = (); 493 %state = ();
476 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url }); 494 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo });
477 }); 495 });
478 $state{handle}->on_eof (sub { 496 $state{handle}->on_eof (sub {
479 %state = (); 497 %state = ();
480 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url }); 498 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo });
481 }); 499 });
482 500
483 $state{handle}->starttls ("connect") if $rscheme eq "https"; 501 $state{handle}->starttls ("connect") if $rscheme eq "https";
484 502
485 # handle actual, non-tunneled, request 503 # handle actual, non-tunneled, request
… …
492 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 510 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
493 . "\015\012" 511 . "\015\012"
494 . (delete $arg{body}) 512 . (delete $arg{body})
495 ); 513 );
496 514
515 # return if error occured during push_write()
516 return unless %state;
517
497 %hdr = (); # reduce memory usage, save a kitten 518 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
498 519
499 # status line 520 # status line
500 $state{handle}->push_read (line => $qr_nl, sub { 521 $state{handle}->push_read (line => $qr_nl, sub {
501 $_[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
502 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 }));
503 524
504 my %hdr = ( # response headers 525 push @pseudo,
505 HTTPVersion => ",$1", 526 HTTPVersion => $1,
506 Status => ",$2", 527 Status => $2,
507 Reason => ",$3", 528 Reason => $3,
508 URL => ",$url"
509 ); 529 ;
510 530
511 # headers, could be optimized a bit 531 # headers, could be optimized a bit
512 $state{handle}->unshift_read (line => $qr_nlnl, sub { 532 $state{handle}->unshift_read (line => $qr_nlnl, sub {
513 for ("$_[1]") { 533 for ("$_[1]") {
514 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.
… …
523 ((?: [^\012]+ | \012[\011\040] )*) 543 ((?: [^\012]+ | \012[\011\040] )*)
524 \012 544 \012
525 /gxc; 545 /gxc;
526 546
527 /\G$/ 547 /\G$/
528 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 }));
529 } 549 }
530 550
551 # remove the "," prefix we added to all headers above
531 substr $_, 0, 1, "" 552 substr $_, 0, 1, ""
532 for values %hdr; 553 for values %hdr;
554
555 # patch in all pseudo headers
556 %hdr = (%hdr, @pseudo);
533 557
534 # redirect handling 558 # redirect handling
535 # 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,
536 # try to support some common forms of broken Location headers. 560 # try to support some common forms of broken Location headers.
537 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { 561 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
… …
548 } 572 }
549 573
550 my $redirect; 574 my $redirect;
551 575
552 if ($recurse) { 576 if ($recurse) {
577 my $status = $hdr{Status};
578
553 if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") { 579 if (($status == 301 || $status == 302) && $method ne "POST") {
554 # apparently, mozilla et al. just change POST to GET here 580 # apparently, mozilla et al. just change POST to GET here
555 # more research is needed before we do the same 581 # more research is needed before we do the same
556 $redirect = 1; 582 $redirect = 1;
557 } elsif ($hdr{Status} == 303) { 583 } elsif ($status == 303) {
558 # 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
559 $method = "GET" unless $method eq "HEAD"; 585 $method = "GET" unless $method eq "HEAD";
560 $redirect = 1; 586 $redirect = 1;
561 } elsif ($hdr{Status} == 307 && $method =~ /^(?:GET|HEAD)$/) { 587 } elsif ($status == 307 && $method =~ /^(?:GET|HEAD)$/) {
562 $redirect = 1; 588 $redirect = 1;
563 } 589 }
564 } 590 }
565 591
566 my $finish = sub { 592 my $finish = sub {
… …
619 645
620 if ($redirect && exists $hdr{location}) { 646 if ($redirect && exists $hdr{location}) {
621 # we ignore any errors, as it is very common to receive 647 # we ignore any errors, as it is very common to receive
622 # Content-Length != 0 but no actual body 648 # Content-Length != 0 but no actual body
623 # we also access %hdr, as $_[1] might be an erro 649 # we also access %hdr, as $_[1] might be an erro
624 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);
625 } else { 656 } else {
626 $cb->($_[0], $_[1]); 657 $cb->($_[0], $_[1]);
627 } 658 }
628 }; 659 };
629 660
630 my $len = $hdr{"content-length"}; 661 my $len = $hdr{"content-length"};
631 662
632 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { 663 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
633 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url }); 664 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
634 } elsif ( 665 } elsif (
635 $hdr{Status} =~ /^(?:1..|[23]04)$/ 666 $hdr{Status} =~ /^(?:1..|[23]04)$/
636 or $method eq "HEAD" 667 or $method eq "HEAD"
637 or (defined $len && !$len) 668 or (defined $len && !$len)
638 ) { 669 ) {
… …
648 $_[0]->on_read (undef); 679 $_[0]->on_read (undef);
649 680
650 $finish->(delete $state{handle}, \%hdr); 681 $finish->(delete $state{handle}, \%hdr);
651 682
652 } elsif ($arg{on_body}) { 683 } elsif ($arg{on_body}) {
653 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) }); 684 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
654 if ($len) { 685 if ($len) {
655 $_[0]->on_eof (undef); 686 $_[0]->on_eof (undef);
656 $_[0]->on_read (sub { 687 $_[0]->on_read (sub {
657 $len -= length $_[0]{rbuf}; 688 $len -= length $_[0]{rbuf};
658 689
659 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 690 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
660 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 });
661 692
662 $len > 0 693 $len > 0
663 or $finish->("", \%hdr); 694 or $finish->("", \%hdr);
664 }); 695 });
665 } else { 696 } else {
666 $_[0]->on_eof (sub { 697 $_[0]->on_eof (sub {
667 $finish->("", \%hdr); 698 $finish->("", \%hdr);
668 }); 699 });
669 $_[0]->on_read (sub { 700 $_[0]->on_read (sub {
670 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 701 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
671 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 });
672 }); 703 });
673 } 704 }
674 } else { 705 } else {
675 $_[0]->on_eof (undef); 706 $_[0]->on_eof (undef);
676 707
677 if ($len) { 708 if ($len) {
678 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) }); 709 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
679 $_[0]->on_read (sub { 710 $_[0]->on_read (sub {
680 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 711 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
681 if $len <= length $_[0]{rbuf}; 712 if $len <= length $_[0]{rbuf};
682 }); 713 });
683 } else { 714 } else {
684 $_[0]->on_error (sub { 715 $_[0]->on_error (sub {
685 $! == Errno::EPIPE || !$! 716 $! == Errno::EPIPE || !$!
686 ? $finish->(delete $_[0]{rbuf}, \%hdr) 717 ? $finish->(delete $_[0]{rbuf}, \%hdr)
687 : $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }); 718 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo });
688 }); 719 });
689 $_[0]->on_read (sub { }); 720 $_[0]->on_read (sub { });
690 } 721 }
691 } 722 }
692 } 723 }
… …
700 731
701 # maybe re-use $uauthority with patched port? 732 # maybe re-use $uauthority with patched port?
702 $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");
703 $state{handle}->push_read (line => $qr_nlnl, sub { 734 $state{handle}->push_read (line => $qr_nlnl, sub {
704 $_[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
705 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 }));
706 737
707 if ($2 == 200) { 738 if ($2 == 200) {
708 $rpath = $upath; 739 $rpath = $upath;
709 &$handle_actual_request; 740 &$handle_actual_request;
710 } else { 741 } else {
711 %state = (); 742 %state = ();
712 $cb->(undef, { Status => $2, Reason => $3, URL => $url }); 743 $cb->(undef, { Status => $2, Reason => $3, @pseudo });
713 } 744 }
714 }); 745 });
715 } else { 746 } else {
716 &$handle_actual_request; 747 &$handle_actual_request;
717 } 748 }
… …
737 unshift @_, "POST", $url, "body"; 768 unshift @_, "POST", $url, "body";
738 &http_request 769 &http_request
739} 770}
740 771
741=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>).
742 782
743=head2 GLOBAL FUNCTIONS AND VARIABLES 783=head2 GLOBAL FUNCTIONS AND VARIABLES
744 784
745=over 4 785=over 4
746 786

Diff Legend

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