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.78 by root, Sat Jan 1 19:32:41 2011 UTC vs.
Revision 1.83 by root, Sun Jan 2 05:02:28 2011 UTC

… …
196=item cookie_jar => $hash_ref 196=item cookie_jar => $hash_ref
197 197
198Passing this parameter enables (simplified) cookie-processing, loosely 198Passing this parameter enables (simplified) cookie-processing, loosely
199based on the original netscape specification. 199based on the original netscape specification.
200 200
201The C<$hash_ref> must be an (initially empty) hash reference which will 201The C<$hash_ref> must be an (initially empty) hash reference which
202get updated automatically. It is possible to save the cookie jar to 202will get updated automatically. It is possible to save the cookie jar
203persistent storage with something like JSON or Storable, but this is not 203to persistent storage with something like JSON or Storable - see the
204recommended, as session-only cookies might survive longer than expected. 204C<AnyEvent::HTTP::cookie_jar_expire> function if you wish to remove
205expired or session-only cookies, and also for documentation on the format
206of the cookie jar.
205 207
206Note that this cookie implementation is not meant to be complete. If 208Note that this cookie implementation is not meant to be complete. If
207you want complete cookie management you have to do that on your 209you want complete cookie management you have to do that on your
208own. C<cookie_jar> is meant as a quick fix to get some cookie-using sites 210own. C<cookie_jar> is meant as a quick fix to get most cookie-using sites
209working. Cookies are a privacy disaster, do not use them unless required 211working. Cookies are a privacy disaster, do not use them unless required
210to. 212to.
211 213
212When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:> 214When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
213headers will be set and handled by this module, otherwise they will be 215headers will be set and handled by this module, otherwise they will be
… …
378 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 380 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
379 381
380 _slot_schedule $_[0]; 382 _slot_schedule $_[0];
381} 383}
382 384
385#############################################################################
386
387# expire cookies
388sub cookie_jar_expire($;$) {
389 my ($jar, $session_end) = @_;
390
391 %$jar = () if $jar->{version} != 1;
392
393 my $anow = AE::now;
394
395 while (my ($chost, $paths) = each %$jar) {
396 next unless ref $paths;
397
398 while (my ($cpath, $cookies) = each %$paths) {
399 while (my ($cookie, $kv) = each %$cookies) {
400 if (exists $kv->{_expires}) {
401 delete $cookies->{$cookie}
402 if $anow > $kv->{_expires};
403 } elsif ($session_end) {
404 delete $cookies->{$cookie};
405 }
406 }
407
408 delete $paths->{$cpath}
409 unless %$cookies;
410 }
411
412 delete $jar->{$chost}
413 unless %$paths;
414 }
415}
416
383# extract cookies from jar 417# extract cookies from jar
384sub cookie_jar_extract($$$$) { 418sub cookie_jar_extract($$$$) {
385 my ($jar, $uscheme, $uhost, $upath) = @_; 419 my ($jar, $uscheme, $uhost, $upath) = @_;
420
421 $uhost = lc $uhost;
386 422
387 %$jar = () if $jar->{version} != 1; 423 %$jar = () if $jar->{version} != 1;
388 424
389 my @cookies; 425 my @cookies;
390 426
… …
403 next unless $cpath eq substr $upath, 0, length $cpath; 439 next unless $cpath eq substr $upath, 0, length $cpath;
404 440
405 while (my ($cookie, $kv) = each %$cookies) { 441 while (my ($cookie, $kv) = each %$cookies) {
406 next if $uscheme ne "https" && exists $kv->{secure}; 442 next if $uscheme ne "https" && exists $kv->{secure};
407 443
408 if (exists $kv->{expires}) { 444 if (exists $kv->{_expires} and AE::now > $kv->{_expires}) {
409 if (AE::now > parse_date ($kv->{expires})) {
410 delete $cookies->{$cookie}; 445 delete $cookies->{$cookie};
411 next; 446 next;
412 }
413 } 447 }
414 448
415 my $value = $kv->{value}; 449 my $value = $kv->{value};
416 450
417 if ($value =~ /[=;,[:space:]]/) { 451 if ($value =~ /[=;,[:space:]]/) {
… …
426 460
427 \@cookies 461 \@cookies
428} 462}
429 463
430# parse set_cookie header into jar 464# parse set_cookie header into jar
431sub cookie_jar_set_cookie($$$) { 465sub cookie_jar_set_cookie($$$$) {
432 my ($jar, $set_cookie, $uhost) = @_; 466 my ($jar, $set_cookie, $uhost, $date) = @_;
467
468 my $anow = int AE::now;
469 my $snow; # server-now
433 470
434 for ($set_cookie) { 471 for ($set_cookie) {
435 # parse NAME=VALUE 472 # parse NAME=VALUE
436 my @kv; 473 my @kv;
437 474
475 # expires is not http-compliant in the original cookie-spec,
476 # we support the official date format and some extensions
438 while ( 477 while (
439 m{ 478 m{
440 \G\s* 479 \G\s*
441 (?: 480 (?:
442 expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+) 481 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+)
443 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) ) 482 | ([^=;,[:space:]]+) (?: \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) ) )?
444 ) 483 )
445 }gcxsi 484 }gcxsi
446 ) { 485 ) {
447 my $name = $2; 486 my $name = $2;
448 my $value = $4; 487 my $value = $4;
449 488
450 unless (defined $name) { 489 if (defined $1) {
451 # expires 490 # expires
452 $name = "expires"; 491 $name = "expires";
453 $value = $1; 492 $value = $1;
454 } elsif (!defined $value) { 493 } elsif (defined $3) {
455 # quoted 494 # quoted
456 $value = $3; 495 $value = $3;
457 $value =~ s/\\(.)/$1/gs; 496 $value =~ s/\\(.)/$1/gs;
458 } 497 }
459 498
… …
465 last unless @kv; 504 last unless @kv;
466 505
467 my $name = shift @kv; 506 my $name = shift @kv;
468 my %kv = (value => shift @kv, @kv); 507 my %kv = (value => shift @kv, @kv);
469 508
470 $kv{expires} ||= format_date (AE::now + $kv{"max-age"})
471 if exists $kv{"max-age"}; 509 if (exists $kv{"max-age"}) {
510 $kv{_expires} = $anow + delete $kv{"max-age"};
511 } elsif (exists $kv{expires}) {
512 $snow ||= parse_date ($date) || $anow;
513 $kv{_expires} = $anow + (parse_date (delete $kv{expires}) - $snow);
514 } else {
515 delete $kv{_expires};
516 }
472 517
473 my $cdom; 518 my $cdom;
474 my $cpath = (delete $kv{path}) || "/"; 519 my $cpath = (delete $kv{path}) || "/";
475 520
476 if (exists $kv{domain}) { 521 if (exists $kv{domain}) {
… …
487 $cdom = $uhost; 532 $cdom = $uhost;
488 } 533 }
489 534
490 # store it 535 # store it
491 $jar->{version} = 1; 536 $jar->{version} = 1;
492 $jar->{$cdom}{$cpath}{$name} = \%kv; 537 $jar->{lc $cdom}{$cpath}{$name} = \%kv;
493 538
494 redo if /\G\s*,/gc; 539 redo if /\G\s*,/gc;
495 } 540 }
496} 541}
497 542
… …
615 $state{slot_guard} = shift; 660 $state{slot_guard} = shift;
616 661
617 return unless $state{connect_guard}; 662 return unless $state{connect_guard};
618 663
619 my $ae_error = 595; # connecting 664 my $ae_error = 595; # connecting
665
666 # handle actual, non-tunneled, request
667 my $handle_actual_request = sub {
668 $ae_error = 596; # request phase
669
670 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
671
672 # send request
673 $state{handle}->push_write (
674 "$method $rpath HTTP/1.1\015\012"
675 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
676 . "\015\012"
677 . (delete $arg{body})
678 );
679
680 # return if error occured during push_write()
681 return unless %state;
682
683 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
684
685 # status line and headers
686 $state{read_response} = sub {
687 for ("$_[1]") {
688 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
689
690 /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
691 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
692
693 # 100 Continue handling
694 # should not happen as we don't send expect: 100-continue,
695 # but we handle it just in case.
696 # since we send the request body regardless, if we get an error
697 # we are out of-sync, which we currently do NOT handle correctly.
698 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
699 if $2 eq 100;
700
701 push @pseudo,
702 HTTPVersion => $1,
703 Status => $2,
704 Reason => $3,
705 ;
706
707 my $hdr = parse_hdr
708 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
709
710 %hdr = (%$hdr, @pseudo);
711 }
712
713 # redirect handling
714 # microsoft and other shitheads don't give a shit for following standards,
715 # try to support some common forms of broken Location headers.
716 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
717 $hdr{location} =~ s/^\.\/+//;
718
719 my $url = "$rscheme://$uhost:$uport";
720
721 unless ($hdr{location} =~ s/^\///) {
722 $url .= $upath;
723 $url =~ s/\/[^\/]*$//;
724 }
725
726 $hdr{location} = "$url/$hdr{location}";
727 }
728
729 my $redirect;
730
731 if ($recurse) {
732 my $status = $hdr{Status};
733
734 # industry standard is to redirect POST as GET for
735 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
736 # also, the UA should ask the user for 301 and 307 and POST,
737 # industry standard seems to be to simply follow.
738 # we go with the industry standard.
739 if ($status == 301 or $status == 302 or $status == 303) {
740 # HTTP/1.1 is unclear on how to mutate the method
741 $method = "GET" unless $method eq "HEAD";
742 $redirect = 1;
743 } elsif ($status == 307) {
744 $redirect = 1;
745 }
746 }
747
748 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
749 my $may_keep_alive = $_[3];
750
751 $state{handle}->destroy if $state{handle};
752 %state = ();
753
754 if (defined $_[1]) {
755 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
756 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
757 }
758
759 # set-cookie processing
760 if ($arg{cookie_jar}) {
761 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost, $hdr{date};
762 }
763
764 if ($redirect && exists $hdr{location}) {
765 # we ignore any errors, as it is very common to receive
766 # Content-Length != 0 but no actual body
767 # we also access %hdr, as $_[1] might be an erro
768 http_request (
769 $method => $hdr{location},
770 %arg,
771 recurse => $recurse - 1,
772 Redirect => [$_[0], \%hdr],
773 $cb);
774 } else {
775 $cb->($_[0], \%hdr);
776 }
777 };
778
779 $ae_error = 597; # body phase
780
781 my $len = $hdr{"content-length"};
782
783 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
784 $finish->(undef, 598 => "Request cancelled by on_header");
785 } elsif (
786 $hdr{Status} =~ /^(?:1..|204|205|304)$/
787 or $method eq "HEAD"
788 or (defined $len && !$len)
789 ) {
790 # no body
791 $finish->("", undef, undef, 1);
792 } else {
793 # body handling, many different code paths
794 # - no body expected
795 # - want_body_handle
796 # - te chunked
797 # - 2x length known (with or without on_body)
798 # - 2x length not known (with or without on_body)
799 if (!$redirect && $arg{want_body_handle}) {
800 $_[0]->on_eof (undef);
801 $_[0]->on_error (undef);
802 $_[0]->on_read (undef);
803
804 $finish->(delete $state{handle});
805
806 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
807 my $cl = 0;
808 my $body = undef;
809 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
810
811 $state{read_chunk} = sub {
812 $_[1] =~ /^([0-9a-fA-F]+)/
813 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
814
815 my $len = hex $1;
816
817 if ($len) {
818 $cl += $len;
819
820 $_[0]->push_read (chunk => $len, sub {
821 $on_body->($_[1], \%hdr)
822 or return $finish->(undef, 598 => "Request cancelled by on_body");
823
824 $_[0]->push_read (line => sub {
825 length $_[1]
826 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
827 $_[0]->push_read (line => $state{read_chunk});
828 });
829 });
830 } else {
831 $hdr{"content-length"} ||= $cl;
832
833 $_[0]->push_read (line => $qr_nlnl, sub {
834 if (length $_[1]) {
835 for ("$_[1]") {
836 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
837
838 my $hdr = parse_hdr
839 or return $finish->(undef, $ae_error => "Garbled response trailers");
840
841 %hdr = (%hdr, %$hdr);
842 }
843 }
844
845 $finish->($body, undef, undef, 1);
846 });
847 }
848 };
849
850 $_[0]->push_read (line => $state{read_chunk});
851
852 } elsif ($arg{on_body}) {
853 if ($len) {
854 $_[0]->on_read (sub {
855 $len -= length $_[0]{rbuf};
856
857 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
858 or return $finish->(undef, 598 => "Request cancelled by on_body");
859
860 $len > 0
861 or $finish->("", undef, undef, 1);
862 });
863 } else {
864 $_[0]->on_eof (sub {
865 $finish->("");
866 });
867 $_[0]->on_read (sub {
868 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
869 or $finish->(undef, 598 => "Request cancelled by on_body");
870 });
871 }
872 } else {
873 $_[0]->on_eof (undef);
874
875 if ($len) {
876 $_[0]->on_read (sub {
877 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
878 if $len <= length $_[0]{rbuf};
879 });
880 } else {
881 $_[0]->on_error (sub {
882 ($! == Errno::EPIPE || !$!)
883 ? $finish->(delete $_[0]{rbuf})
884 : $finish->(undef, $ae_error => $_[2]);
885 });
886 $_[0]->on_read (sub { });
887 }
888 }
889 }
890 };
891
892 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
893 };
620 894
621 my $connect_cb = sub { 895 my $connect_cb = sub {
622 $state{fh} = shift 896 $state{fh} = shift
623 or do { 897 or do {
624 my $err = "$!"; 898 my $err = "$!";
… …
655# $hdr{connection} = "keep-alive"; 929# $hdr{connection} = "keep-alive";
656# } 930# }
657 931
658 $state{handle}->starttls ("connect") if $rscheme eq "https"; 932 $state{handle}->starttls ("connect") if $rscheme eq "https";
659 933
660 # handle actual, non-tunneled, request
661 my $handle_actual_request = sub {
662 $ae_error = 596; # request phase
663
664 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
665
666 # send request
667 $state{handle}->push_write (
668 "$method $rpath HTTP/1.1\015\012"
669 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
670 . "\015\012"
671 . (delete $arg{body})
672 );
673
674 # return if error occured during push_write()
675 return unless %state;
676
677 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
678
679 # status line and headers
680 $state{read_response} = sub {
681 for ("$_[1]") {
682 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
683
684 /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
685 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
686
687 # 100 Continue handling
688 # should not happen as we don't send expect: 100-continue,
689 # but we handle it just in case.
690 # since we send the request body regardless, if we get an error
691 # we are out of-sync, which we currently do NOT handle correctly.
692 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
693 if $2 eq 100;
694
695 push @pseudo,
696 HTTPVersion => $1,
697 Status => $2,
698 Reason => $3,
699 ;
700
701 my $hdr = parse_hdr
702 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
703
704 %hdr = (%$hdr, @pseudo);
705 }
706
707 # redirect handling
708 # microsoft and other shitheads don't give a shit for following standards,
709 # try to support some common forms of broken Location headers.
710 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
711 $hdr{location} =~ s/^\.\/+//;
712
713 my $url = "$rscheme://$uhost:$uport";
714
715 unless ($hdr{location} =~ s/^\///) {
716 $url .= $upath;
717 $url =~ s/\/[^\/]*$//;
718 }
719
720 $hdr{location} = "$url/$hdr{location}";
721 }
722
723 my $redirect;
724
725 if ($recurse) {
726 my $status = $hdr{Status};
727
728 # industry standard is to redirect POST as GET for
729 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
730 # also, the UA should ask the user for 301 and 307 and POST,
731 # industry standard seems to be to simply follow.
732 # we go with the industry standard.
733 if ($status == 301 or $status == 302 or $status == 303) {
734 # HTTP/1.1 is unclear on how to mutate the method
735 $method = "GET" unless $method eq "HEAD";
736 $redirect = 1;
737 } elsif ($status == 307) {
738 $redirect = 1;
739 }
740 }
741
742 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
743 my $may_keep_alive = $_[3];
744
745 $state{handle}->destroy if $state{handle};
746 %state = ();
747
748 if (defined $_[1]) {
749 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
750 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
751 }
752
753 # set-cookie processing
754 if ($arg{cookie_jar}) {
755 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost;
756 }
757
758 if ($redirect && exists $hdr{location}) {
759 # we ignore any errors, as it is very common to receive
760 # Content-Length != 0 but no actual body
761 # we also access %hdr, as $_[1] might be an erro
762 http_request (
763 $method => $hdr{location},
764 %arg,
765 recurse => $recurse - 1,
766 Redirect => [$_[0], \%hdr],
767 $cb);
768 } else {
769 $cb->($_[0], \%hdr);
770 }
771 };
772
773 $ae_error = 597; # body phase
774
775 my $len = $hdr{"content-length"};
776
777 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
778 $finish->(undef, 598 => "Request cancelled by on_header");
779 } elsif (
780 $hdr{Status} =~ /^(?:1..|204|205|304)$/
781 or $method eq "HEAD"
782 or (defined $len && !$len)
783 ) {
784 # no body
785 $finish->("", undef, undef, 1);
786 } else {
787 # body handling, many different code paths
788 # - no body expected
789 # - want_body_handle
790 # - te chunked
791 # - 2x length known (with or without on_body)
792 # - 2x length not known (with or without on_body)
793 if (!$redirect && $arg{want_body_handle}) {
794 $_[0]->on_eof (undef);
795 $_[0]->on_error (undef);
796 $_[0]->on_read (undef);
797
798 $finish->(delete $state{handle});
799
800 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
801 my $cl = 0;
802 my $body = undef;
803 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
804
805 my $read_chunk; $read_chunk = sub {
806 $_[1] =~ /^([0-9a-fA-F]+)/
807 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
808
809 my $len = hex $1;
810
811 if ($len) {
812 $cl += $len;
813
814 $_[0]->push_read (chunk => $len, sub {
815 $on_body->($_[1], \%hdr)
816 or return $finish->(undef, 598 => "Request cancelled by on_body");
817
818 $_[0]->push_read (line => sub {
819 length $_[1]
820 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
821 $_[0]->push_read (line => $read_chunk);
822 });
823 });
824 } else {
825 $hdr{"content-length"} ||= $cl;
826
827 $_[0]->push_read (line => $qr_nlnl, sub {
828 if (length $_[1]) {
829 for ("$_[1]") {
830 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
831
832 my $hdr = parse_hdr
833 or return $finish->(undef, $ae_error => "Garbled response trailers");
834
835 %hdr = (%hdr, %$hdr);
836 }
837 }
838
839 $finish->($body, undef, undef, 1);
840 });
841 }
842 };
843
844 $_[0]->push_read (line => $read_chunk);
845
846 } elsif ($arg{on_body}) {
847 if ($len) {
848 $_[0]->on_read (sub {
849 $len -= length $_[0]{rbuf};
850
851 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
852 or return $finish->(undef, 598 => "Request cancelled by on_body");
853
854 $len > 0
855 or $finish->("", undef, undef, 1);
856 });
857 } else {
858 $_[0]->on_eof (sub {
859 $finish->("");
860 });
861 $_[0]->on_read (sub {
862 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
863 or $finish->(undef, 598 => "Request cancelled by on_body");
864 });
865 }
866 } else {
867 $_[0]->on_eof (undef);
868
869 if ($len) {
870 $_[0]->on_read (sub {
871 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
872 if $len <= length $_[0]{rbuf};
873 });
874 } else {
875 $_[0]->on_error (sub {
876 ($! == Errno::EPIPE || !$!)
877 ? $finish->(delete $_[0]{rbuf})
878 : $finish->(undef, $ae_error => $_[2]);
879 });
880 $_[0]->on_read (sub { });
881 }
882 }
883 }
884 };
885
886 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
887 };
888
889 # now handle proxy-CONNECT method 934 # now handle proxy-CONNECT method
890 if ($proxy && $uscheme eq "https") { 935 if ($proxy && $uscheme eq "https") {
891 # oh dear, we have to wrap it into a connect request 936 # oh dear, we have to wrap it into a connect request
892 937
893 # maybe re-use $uauthority with patched port? 938 # maybe re-use $uauthority with patched port?
… …
896 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 941 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
897 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" })); 942 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
898 943
899 if ($2 == 200) { 944 if ($2 == 200) {
900 $rpath = $upath; 945 $rpath = $upath;
901 &$handle_actual_request; 946 $handle_actual_request->();
902 } else { 947 } else {
903 %state = (); 948 %state = ();
904 $cb->(undef, { @pseudo, Status => $2, Reason => $3 }); 949 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
905 } 950 }
906 }); 951 });
907 } else { 952 } else {
908 &$handle_actual_request; 953 $handle_actual_request->();
909 } 954 }
910 }; 955 };
911 956
912 my $tcp_connect = $arg{tcp_connect} 957 my $tcp_connect = $arg{tcp_connect}
913 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect }; 958 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
914 959
915 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout }); 960 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
916
917 }; 961 };
918 962
919 defined wantarray && AnyEvent::Util::guard { %state = () } 963 defined wantarray && AnyEvent::Util::guard { %state = () }
920} 964}
921 965
… …
956string of the form C<http://host:port> (optionally C<https:...>), croaks 1000string of the form C<http://host:port> (optionally C<https:...>), croaks
957otherwise. 1001otherwise.
958 1002
959To clear an already-set proxy, use C<undef>. 1003To clear an already-set proxy, use C<undef>.
960 1004
1005=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
1006
1007Remove all cookies from the cookie jar that have been expired. If
1008C<$session_end> is given and true, then additionally remove all session
1009cookies.
1010
1011You should call this function (with a true C<$session_end>) before you
1012save cookies to disk, and you should call this function after loading them
1013again. If you have a long-running program you can additonally call this
1014function from time to time.
1015
1016A cookie jar is initially an empty hash-reference that is managed by this
1017module. It's format is subject to change, but currently it is like this:
1018
1019The key C<version> has to contain C<1>, otherwise the hash gets
1020emptied. All other keys are hostnames or IP addresses pointing to
1021hash-references. The key for these inner hash references is the
1022server path for which this cookie is meant, and the values are again
1023hash-references. The keys of those hash-references is the cookie name, and
1024the value, you guessed it, is another hash-reference, this time with the
1025key-value pairs from the cookie, except for C<expires> and C<max-age>,
1026which have been replaced by a C<_expires> key that contains the cookie
1027expiry timestamp.
1028
1029Here is an example of a cookie jar with a single cookie, so you have a
1030chance of understanding the above paragraph:
1031
1032 {
1033 version => 1,
1034 "10.0.0.1" => {
1035 "/" => {
1036 "mythweb_id" => {
1037 _expires => 1293917923,
1038 value => "ooRung9dThee3ooyXooM1Ohm",
1039 },
1040 },
1041 },
1042 }
1043
961=item $date = AnyEvent::HTTP::format_date $timestamp 1044=item $date = AnyEvent::HTTP::format_date $timestamp
962 1045
963Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP 1046Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
964Date (RFC 2616). 1047Date (RFC 2616).
965 1048
966=item $timestamp = AnyEvent::HTTP::parse_date $date 1049=item $timestamp = AnyEvent::HTTP::parse_date $date
967 1050
968Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and 1051Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) or a
969returns the corresponding POSIX timestamp, or C<undef> if the date cannot 1052bunch of minor variations of those, and returns the corresponding POSIX
970be parsed. 1053timestamp, or C<undef> if the date cannot be parsed.
971 1054
972=item $AnyEvent::HTTP::MAX_RECURSE 1055=item $AnyEvent::HTTP::MAX_RECURSE
973 1056
974The default value for the C<recurse> request parameter (default: C<10>). 1057The default value for the C<recurse> request parameter (default: C<10>).
975 1058
… …
1014sub parse_date($) { 1097sub parse_date($) {
1015 my ($date) = @_; 1098 my ($date) = @_;
1016 1099
1017 my ($d, $m, $y, $H, $M, $S); 1100 my ($d, $m, $y, $H, $M, $S);
1018 1101
1019 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$/) { 1102 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$/) {
1020 # RFC 822/1123, required by RFC 2616 (with " ") 1103 # RFC 822/1123, required by RFC 2616 (with " ")
1021 # cookie dates (with "-") 1104 # cookie dates (with "-")
1022 1105
1023 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6); 1106 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
1024 1107
1025 } 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$/) { 1108 } elsif ($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]?) GMT$/) {
1026 # RFC 850 1109 # RFC 850
1027 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6); 1110 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
1028 1111
1029 } 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])$/) { 1112 } 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])$/) {
1030 # ISO C's asctime 1113 # ISO C's asctime
1031 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5); 1114 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
1032 } 1115 }
1033 # other formats fail in the loop below 1116 # other formats fail in the loop below
1034 1117

Diff Legend

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