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.58 by root, Sun Nov 14 20:23:00 2010 UTC vs.
Revision 1.67 by root, Fri Dec 31 06:18:54 2010 UTC

… …
43 43
44use Errno (); 44use Errno ();
45 45
46use AnyEvent 5.0 (); 46use AnyEvent 5.0 ();
47use AnyEvent::Util (); 47use AnyEvent::Util ();
48use AnyEvent::Socket ();
49use AnyEvent::Handle (); 48use AnyEvent::Handle ();
50 49
51use base Exporter::; 50use base Exporter::;
52 51
53our $VERSION = '1.46'; 52our $VERSION = '1.5';
54 53
55our @EXPORT = qw(http_get http_post http_head http_request); 54our @EXPORT = qw(http_get http_post http_head http_request);
56 55
57our $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)";
58our $MAX_RECURSE = 10; 57our $MAX_RECURSE = 10;
… …
101second argument. 100second argument.
102 101
103All 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
104headers, the "pseudo-headers" (uppercase to avoid clashing with possible 103headers, the "pseudo-headers" (uppercase to avoid clashing with possible
105response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the 104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
106three 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>.
107 109
108The 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
109the requested URL when following redirects - for example, you might get 111the 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 112an 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 113valid http URL because it redirected to an ftp URL, in which case you can
… …
211connect (for exmaple, to bind it on a given IP address). This parameter 213connect (for exmaple, to bind it on a given IP address). This parameter
212overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect> 214overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
213and behaves exactly the same way (e.g. it has to provide a 215and behaves exactly the same way (e.g. it has to provide a
214timeout). See the description for the C<$prepare_cb> argument of 216timeout). See the description for the C<$prepare_cb> argument of
215C<AnyEvent::Socket::tcp_connect> for details. 217C<AnyEvent::Socket::tcp_connect> for details.
218
219=item tcp_connect => $callback->($host, $service, $connect_cb, $prepare_cb)
220
221In even rarer cases you want total control over how AnyEvent::HTTP
222establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
223to do this, but you can provide your own C<tcp_connect> function -
224obviously, it has to follow the same calling conventions, except that it
225may always return a connection guard object.
226
227There are probably lots of weird uses for this function, starting from
228tracing the hosts C<http_request> actually tries to connect, to (inexact
229but fast) host => IP address caching or even socks protocol support.
216 230
217=item on_header => $callback->($headers) 231=item on_header => $callback->($headers)
218 232
219When specified, this callback will be called with the header hash as soon 233When specified, this callback will be called with the header hash as soon
220as headers have been successfully received from the remote server (not on 234as headers have been successfully received from the remote server (not on
… …
338 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 352 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
339 353
340 _slot_schedule $_[0]; 354 _slot_schedule $_[0];
341} 355}
342 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
343our $qr_nlnl = qr{(?<![^\012])\015?\012}; 382our $qr_nlnl = qr{(?<![^\012])\015?\012};
344 383
345our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 384our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
346our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 385our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
347 386
… …
366 my @pseudo = (URL => $url); 405 my @pseudo = (URL => $url);
367 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect}; 406 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
368 407
369 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 408 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
370 409
371 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo }) 410 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
372 if $recurse < 0; 411 if $recurse < 0;
373 412
374 my $proxy = $arg{proxy} || $PROXY; 413 my $proxy = $arg{proxy} || $PROXY;
375 my $timeout = $arg{timeout} || $TIMEOUT; 414 my $timeout = $arg{timeout} || $TIMEOUT;
376 415
… …
379 418
380 $uscheme = lc $uscheme; 419 $uscheme = lc $uscheme;
381 420
382 my $uport = $uscheme eq "http" ? 80 421 my $uport = $uscheme eq "http" ? 80
383 : $uscheme eq "https" ? 443 422 : $uscheme eq "https" ? 443
384 : 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" });
385 424
386 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 425 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
387 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo }); 426 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
388 427
389 my $uhost = $1; 428 my $uhost = $1;
390 $uport = $2 if defined $2; 429 $uport = $2 if defined $2;
391 430
392 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost" 431 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
… …
441 } else { 480 } else {
442 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 481 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
443 } 482 }
444 483
445 # leave out fragment and query string, just a heuristic 484 # leave out fragment and query string, just a heuristic
446 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; 485 $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
447 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; 486 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
448 487
449 $hdr{"content-length"} = length $arg{body} 488 $hdr{"content-length"} = length $arg{body}
450 if length $arg{body} || $method ne "GET"; 489 if length $arg{body} || $method ne "GET";
451 490
491 $hdr{connection} = "close TE";
492 $hdr{te} = "trailers" unless exists $hdr{te};
493
452 my %state = (connect_guard => 1); 494 my %state = (connect_guard => 1);
453 495
454 _get_slot $uhost, sub { 496 _get_slot $uhost, sub {
455 $state{slot_guard} = shift; 497 $state{slot_guard} = shift;
456 498
457 return unless $state{connect_guard}; 499 return unless $state{connect_guard};
458 500
459 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 501 my $connect_cb = sub {
460 $state{fh} = shift 502 $state{fh} = shift
461 or do { 503 or do {
462 my $err = "$!"; 504 my $err = "$!";
463 %state = (); 505 %state = ();
464 return $cb->(undef, { Status => 599, Reason => $err, @pseudo }); 506 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
465 }; 507 };
466 508
467 pop; # free memory, save a tree 509 pop; # free memory, save a tree
468 510
469 return unless delete $state{connect_guard}; 511 return unless delete $state{connect_guard};
… …
475 tls_ctx => $arg{tls_ctx}, 517 tls_ctx => $arg{tls_ctx},
476 # these need to be reconfigured on keepalive handles 518 # these need to be reconfigured on keepalive handles
477 timeout => $timeout, 519 timeout => $timeout,
478 on_error => sub { 520 on_error => sub {
479 %state = (); 521 %state = ();
480 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo }); 522 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
481 }, 523 },
482 on_eof => sub { 524 on_eof => sub {
483 %state = (); 525 %state = ();
484 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo }); 526 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
485 }, 527 },
486 ; 528 ;
487 529
488 # limit the number of persistent connections 530 # limit the number of persistent connections
489 # keepalive not yet supported 531 # keepalive not yet supported
… …
492# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 534# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
493# --$KA_COUNT{$_[1]} 535# --$KA_COUNT{$_[1]}
494# }; 536# };
495# $hdr{connection} = "keep-alive"; 537# $hdr{connection} = "keep-alive";
496# } else { 538# } else {
497 delete $hdr{connection}; 539# delete $hdr{connection};
498# } 540# }
499 541
500 $state{handle}->starttls ("connect") if $rscheme eq "https"; 542 $state{handle}->starttls ("connect") if $rscheme eq "https";
501 543
502 # handle actual, non-tunneled, request 544 # handle actual, non-tunneled, request
503 my $handle_actual_request = sub { 545 my $handle_actual_request = sub {
504 $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};
505 547
506 # send request 548 # send request
507 $state{handle}->push_write ( 549 $state{handle}->push_write (
508 "$method $rpath HTTP/1.0\015\012" 550 "$method $rpath HTTP/1.1\015\012"
509 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 551 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
510 . "\015\012" 552 . "\015\012"
511 . (delete $arg{body}) 553 . (delete $arg{body})
512 ); 554 );
513 555
… …
516 558
517 %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
518 560
519 # status line and headers 561 # status line and headers
520 $state{handle}->push_read (line => $qr_nlnl, sub { 562 $state{handle}->push_read (line => $qr_nlnl, sub {
563 my $keepalive = pop;
564
521 for ("$_[1]") { 565 for ("$_[1]") {
522 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.
523 567
524 /^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
525 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" }));
526 570
527 push @pseudo, 571 push @pseudo,
528 HTTPVersion => $1, 572 HTTPVersion => $1,
529 Status => $2, 573 Status => $2,
530 Reason => $3, 574 Reason => $3,
531 ; 575 ;
532 576
533 # things seen, not parsed: 577 my $hdr = parse_hdr
534 # p3pP="NON CUR OTPi OUR NOR UNI"
535
536 $hdr{lc $1} .= ",$2"
537 while /\G
538 ([^:\000-\037]*):
539 [\011\040]*
540 ((?: [^\012]+ | \012[\011\040] )*)
541 \012
542 /gxc;
543
544 /\G$/
545 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);
546 } 581 }
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 582
555 # redirect handling 583 # redirect handling
556 # microsoft and other shitheads don't give a shit for following standards, 584 # microsoft and other shitheads don't give a shit for following standards,
557 # try to support some common forms of broken Location headers. 585 # try to support some common forms of broken Location headers.
558 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { 586 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
… …
585 } elsif ($status == 307) { 613 } elsif ($status == 307) {
586 $redirect = 1; 614 $redirect = 1;
587 } 615 }
588 } 616 }
589 617
590 my $finish = sub { 618 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
591 $state{handle}->destroy if $state{handle}; 619 $state{handle}->destroy if $state{handle};
592 %state = (); 620 %state = ();
593 621
622 if (defined $_[1]) {
623 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
624 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
625 }
626
594 # set-cookie processing 627 # set-cookie processing
595 if ($arg{cookie_jar}) { 628 if ($arg{cookie_jar}) {
596 for ($_[1]{"set-cookie"}) { 629 for ($hdr{"set-cookie"}) {
597 # parse NAME=VALUE 630 # parse NAME=VALUE
598 my @kv; 631 my @kv;
599 632
600 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) { 633 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
601 my $name = $1; 634 my $name = $1;
… …
647 # we also access %hdr, as $_[1] might be an erro 680 # we also access %hdr, as $_[1] might be an erro
648 http_request ( 681 http_request (
649 $method => $hdr{location}, 682 $method => $hdr{location},
650 %arg, 683 %arg,
651 recurse => $recurse - 1, 684 recurse => $recurse - 1,
652 Redirect => \@_, 685 Redirect => [$_[0], \%hdr],
653 $cb); 686 $cb);
654 } else { 687 } else {
655 $cb->($_[0], $_[1]); 688 $cb->($_[0], \%hdr);
656 } 689 }
657 }; 690 };
658 691
659 my $len = $hdr{"content-length"}; 692 my $len = $hdr{"content-length"};
660 693
661 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { 694 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
662 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo }); 695 $finish->(undef, 598 => "Request cancelled by on_header");
663 } elsif ( 696 } elsif (
664 $hdr{Status} =~ /^(?:1..|[23]04)$/ 697 $hdr{Status} =~ /^(?:1..|204|205|304)$/
665 or $method eq "HEAD" 698 or $method eq "HEAD"
666 or (defined $len && !$len) 699 or (defined $len && !$len)
667 ) { 700 ) {
668 # no body 701 # no body
669 $finish->("", \%hdr); 702 $finish->("", undef, undef, 1);
670 } else { 703 } else {
671 # body handling, four different code paths 704 # body handling, many different code paths
672 # for want_body_handle, on_body (2x), normal (2x) 705 # - no body expected
673 # 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)
674 if (!$redirect && $arg{want_body_handle}) { 710 if (!$redirect && $arg{want_body_handle}) {
675 $_[0]->on_eof (undef); 711 $_[0]->on_eof (undef);
676 $_[0]->on_error (undef); 712 $_[0]->on_error (undef);
677 $_[0]->on_read (undef); 713 $_[0]->on_read (undef);
678 714
679 $finish->(delete $state{handle}, \%hdr); 715 $finish->(delete $state{handle});
716
717 } elsif ($hdr{"transfer-encoding"} =~ /chunked/) {
718 my $body = undef;
719 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
720
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
729 if ($len) {
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
734 $_[0]->push_read (line => sub {
735 length $_[1]
736 and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
737 $_[0]->push_read (line => $read_chunk);
738 });
739 });
740 } else {
741 $_[0]->push_read (line => $qr_nlnl, sub {
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 }
751 }
752
753 $finish->($body, undef, undef, 1);
754 });
755 }
756 };
757
758 $_[0]->push_read (line => $read_chunk);
680 759
681 } elsif ($arg{on_body}) { 760 } elsif ($arg{on_body}) {
682 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) }); 761 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
762
683 if ($len) { 763 if ($len) {
684 $_[0]->on_eof (undef);
685 $_[0]->on_read (sub { 764 $_[0]->on_read (sub {
686 $len -= length $_[0]{rbuf}; 765 $len -= length $_[0]{rbuf};
687 766
688 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 767 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
689 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo }); 768 or return $finish->(undef, 598 => "Request cancelled by on_body");
690 769
691 $len > 0 770 $len > 0
692 or $finish->("", \%hdr); 771 or $finish->("", undef, undef, 1);
693 }); 772 });
694 } else { 773 } else {
695 $_[0]->on_eof (sub { 774 $_[0]->on_eof (sub {
696 $finish->("", \%hdr); 775 $finish->("");
697 }); 776 });
698 $_[0]->on_read (sub { 777 $_[0]->on_read (sub {
699 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 778 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
700 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo }); 779 or $finish->(undef, 598 => "Request cancelled by on_body");
701 }); 780 });
702 } 781 }
703 } else { 782 } else {
704 $_[0]->on_eof (undef); 783 $_[0]->on_eof (undef);
705 784
706 if ($len) { 785 if ($len) {
707 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) }); 786 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
708 $_[0]->on_read (sub { 787 $_[0]->on_read (sub {
709 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 788 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
710 if $len <= length $_[0]{rbuf}; 789 if $len <= length $_[0]{rbuf};
711 }); 790 });
712 } else { 791 } else {
713 $_[0]->on_error (sub { 792 $_[0]->on_error (sub {
714 ($! == Errno::EPIPE || !$!) 793 ($! == Errno::EPIPE || !$!)
715 ? $finish->(delete $_[0]{rbuf}, \%hdr) 794 ? $finish->(delete $_[0]{rbuf})
716 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }); 795 : $finish->(undef, 599 => $_[2]);
717 }); 796 });
718 $_[0]->on_read (sub { }); 797 $_[0]->on_read (sub { });
719 } 798 }
720 } 799 }
721 } 800 }
… …
728 807
729 # maybe re-use $uauthority with patched port? 808 # maybe re-use $uauthority with patched port?
730 $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");
731 $state{handle}->push_read (line => $qr_nlnl, sub { 810 $state{handle}->push_read (line => $qr_nlnl, sub {
732 $_[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
733 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])" }));
734 813
735 if ($2 == 200) { 814 if ($2 == 200) {
736 $rpath = $upath; 815 $rpath = $upath;
737 &$handle_actual_request; 816 &$handle_actual_request;
738 } else { 817 } else {
739 %state = (); 818 %state = ();
740 $cb->(undef, { Status => $2, Reason => $3, @pseudo }); 819 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
741 } 820 }
742 }); 821 });
743 } else { 822 } else {
744 &$handle_actual_request; 823 &$handle_actual_request;
745 } 824 }
825 };
746 826
747 }, $arg{on_prepare} || sub { $timeout }; 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
748 }; 832 };
749 833
750 defined wantarray && AnyEvent::Util::guard { %state = () } 834 defined wantarray && AnyEvent::Util::guard { %state = () }
751} 835}
752 836
… …
787string of the form C<http://host:port> (optionally C<https:...>), croaks 871string of the form C<http://host:port> (optionally C<https:...>), croaks
788otherwise. 872otherwise.
789 873
790To clear an already-set proxy, use C<undef>. 874To clear an already-set proxy, use C<undef>.
791 875
876=item $date = AnyEvent::HTTP::format_date $timestamp
877
878Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
879Date (RFC 2616).
880
881=item $timestamp = AnyEvent::HTTP::parse_date $date
882
883Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
884timestamp, or C<undef> if the date cannot be parsed.
885
792=item $AnyEvent::HTTP::MAX_RECURSE 886=item $AnyEvent::HTTP::MAX_RECURSE
793 887
794The default value for the C<recurse> request parameter (default: C<10>). 888The default value for the C<recurse> request parameter (default: C<10>).
795 889
796=item $AnyEvent::HTTP::USERAGENT 890=item $AnyEvent::HTTP::USERAGENT
… …
814connections. This number of can be useful for load-leveling. 908connections. This number of can be useful for load-leveling.
815 909
816=back 910=back
817 911
818=cut 912=cut
913
914our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
915our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
916
917sub format_date($) {
918 my ($time) = @_;
919
920 # RFC 822/1123 format
921 my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
922
923 sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
924 $weekday[$wday], $mday, $month[$mon], $year + 1900,
925 $H, $M, $S;
926}
927
928sub parse_date($) {
929 my ($date) = @_;
930
931 my ($d, $m, $y, $H, $M, $S);
932
933 if ($date =~ /^[A-Z][a-z][a-z], ([0-9][0-9]) ([A-Z][a-z][a-z]) ([0-9][0-9][0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
934 # RFC 822/1123, required by RFC 2616
935 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
936
937 } elsif ($date =~ /^[A-Z][a-z]+, ([0-9][0-9])-([A-Z][a-z][a-z])-([0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
938 # RFC 850
939 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
940
941 } elsif ($date =~ /^[A-Z][a-z][a-z] ([A-Z][a-z][a-z]) ([0-9 ][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) ([0-9][0-9][0-9][0-9])$/) {
942 # ISO C's asctime
943 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
944 }
945 # other formats fail in the loop below
946
947 for (0..11) {
948 if ($m eq $month[$_]) {
949 require Time::Local;
950 return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
951 }
952 }
953
954 undef
955}
819 956
820sub set_proxy($) { 957sub set_proxy($) {
821 if (length $_[0]) { 958 if (length $_[0]) {
822 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix 959 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
823 or Carp::croak "$_[0]: invalid proxy URL"; 960 or Carp::croak "$_[0]: invalid proxy URL";
… …
830# initialise proxy from environment 967# initialise proxy from environment
831eval { 968eval {
832 set_proxy $ENV{http_proxy}; 969 set_proxy $ENV{http_proxy};
833}; 970};
834 971
972=head2 SOCKS PROXIES
973
974Socks proxies are not directly supported by AnyEvent::HTTP. You can
975compile your perl to support socks, or use an external program such as
976F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
977transparently.
978
979Alternatively, for AnyEvent::HTTP only, you can use your own
980C<tcp_connect> function that does the proxy handshake - here is an example
981that works with socks4a proxies:
982
983 use Errno;
984 use AnyEvent::Util;
985 use AnyEvent::Socket;
986 use AnyEvent::Handle;
987
988 # host, port and username of/for your socks4a proxy
989 my $socks_host = "10.0.0.23";
990 my $socks_port = 9050;
991 my $socks_user = "";
992
993 sub socks4a_connect {
994 my ($host, $port, $connect_cb, $prepare_cb) = @_;
995
996 my $hdl = new AnyEvent::Handle
997 connect => [$socks_host, $socks_port],
998 on_prepare => sub { $prepare_cb->($_[0]{fh}) },
999 on_error => sub { $connect_cb->() },
1000 ;
1001
1002 $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
1003
1004 $hdl->push_read (chunk => 8, sub {
1005 my ($hdl, $chunk) = @_;
1006 my ($status, $port, $ipn) = unpack "xCna4", $chunk;
1007
1008 if ($status == 0x5a) {
1009 $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
1010 } else {
1011 $! = Errno::ENXIO; $connect_cb->();
1012 }
1013 });
1014
1015 $hdl
1016 }
1017
1018Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
1019possibly after switching off other proxy types:
1020
1021 AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
1022
1023 http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
1024 my ($data, $headers) = @_;
1025 ...
1026 };
1027
835=head1 SEE ALSO 1028=head1 SEE ALSO
836 1029
837L<AnyEvent>. 1030L<AnyEvent>.
838 1031
839=head1 AUTHOR 1032=head1 AUTHOR

Diff Legend

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