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.79 by root, Sat Jan 1 20:01:07 2011 UTC vs.
Revision 1.84 by root, Sun Jan 2 05:13:27 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
… …
440 while ( 477 while (
441 m{ 478 m{
442 \G\s* 479 \G\s*
443 (?: 480 (?:
444 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+) 481 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+)
445 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) ) 482 | ([^=;,[:space:]]+) (?: \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) ) )?
446 ) 483 )
447 }gcxsi 484 }gcxsi
448 ) { 485 ) {
449 my $name = $2; 486 my $name = $2;
450 my $value = $4; 487 my $value = $4;
451 488
452 unless (defined $name) { 489 if (defined $1) {
453 # expires 490 # expires
454 $name = "expires"; 491 $name = "expires";
455 $value = $1; 492 $value = $1;
456 } elsif (!defined $value) { 493 } elsif (defined $3) {
457 # quoted 494 # quoted
458 $value = $3; 495 $value = $3;
459 $value =~ s/\\(.)/$1/gs; 496 $value =~ s/\\(.)/$1/gs;
460 } 497 }
461 498
… …
467 last unless @kv; 504 last unless @kv;
468 505
469 my $name = shift @kv; 506 my $name = shift @kv;
470 my %kv = (value => shift @kv, @kv); 507 my %kv = (value => shift @kv, @kv);
471 508
472 $kv{expires} ||= format_date (AE::now + $kv{"max-age"})
473 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 }
474 517
475 my $cdom; 518 my $cdom;
476 my $cpath = (delete $kv{path}) || "/"; 519 my $cpath = (delete $kv{path}) || "/";
477 520
478 if (exists $kv{domain}) { 521 if (exists $kv{domain}) {
… …
489 $cdom = $uhost; 532 $cdom = $uhost;
490 } 533 }
491 534
492 # store it 535 # store it
493 $jar->{version} = 1; 536 $jar->{version} = 1;
494 $jar->{$cdom}{$cpath}{$name} = \%kv; 537 $jar->{lc $cdom}{$cpath}{$name} = \%kv;
495 538
496 redo if /\G\s*,/gc; 539 redo if /\G\s*,/gc;
497 } 540 }
498} 541}
499 542
… …
617 $state{slot_guard} = shift; 660 $state{slot_guard} = shift;
618 661
619 return unless $state{connect_guard}; 662 return unless $state{connect_guard};
620 663
621 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 warn "no content $redirect x<$len>$hdr{Status}\n";#d#
783
784 # body handling, many different code paths
785 # - no body expected
786 # - want_body_handle
787 # - te chunked
788 # - 2x length known (with or without on_body)
789 # - 2x length not known (with or without on_body)
790 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
791 $finish->(undef, 598 => "Request cancelled by on_header");
792 } elsif (
793 $hdr{Status} =~ /^(?:1..|204|205|304)$/
794 or $method eq "HEAD"
795 or (defined $len && $len == 0) # == 0, not !, because "0 " is true
796 ) {
797 # no body
798 $finish->("", undef, undef, 1);
799
800 } elsif (!$redirect && $arg{want_body_handle}) {
801 $_[0]->on_eof (undef);
802 $_[0]->on_error (undef);
803 $_[0]->on_read (undef);
804
805 $finish->(delete $state{handle});
806
807 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
808 my $cl = 0;
809 my $body = undef;
810 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
811
812 $state{read_chunk} = sub {
813 $_[1] =~ /^([0-9a-fA-F]+)/
814 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
815
816 my $len = hex $1;
817
818 if ($len) {
819 $cl += $len;
820
821 $_[0]->push_read (chunk => $len, sub {
822 $on_body->($_[1], \%hdr)
823 or return $finish->(undef, 598 => "Request cancelled by on_body");
824
825 $_[0]->push_read (line => sub {
826 length $_[1]
827 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
828 $_[0]->push_read (line => $state{read_chunk});
829 });
830 });
831 } else {
832 $hdr{"content-length"} ||= $cl;
833
834 $_[0]->push_read (line => $qr_nlnl, sub {
835 if (length $_[1]) {
836 for ("$_[1]") {
837 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
838
839 my $hdr = parse_hdr
840 or return $finish->(undef, $ae_error => "Garbled response trailers");
841
842 %hdr = (%hdr, %$hdr);
843 }
844 }
845
846 $finish->($body, undef, undef, 1);
847 });
848 }
849 };
850
851 $_[0]->push_read (line => $state{read_chunk});
852
853 } elsif ($arg{on_body}) {
854 if (defined $len) {
855 $_[0]->on_read (sub {
856 $len -= length $_[0]{rbuf};
857
858 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
859 or return $finish->(undef, 598 => "Request cancelled by on_body");
860
861 $len > 0
862 or $finish->("", undef, undef, 1);
863 });
864 } else {
865 $_[0]->on_eof (sub {
866 $finish->("");
867 });
868 $_[0]->on_read (sub {
869 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
870 or $finish->(undef, 598 => "Request cancelled by on_body");
871 });
872 }
873 } else {
874 $_[0]->on_eof (undef);
875
876 if (defined $len) {
877 $_[0]->on_read (sub {
878 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
879 if $len <= length $_[0]{rbuf};
880 });
881 } else {
882 $_[0]->on_error (sub {
883 ($! == Errno::EPIPE || !$!)
884 ? $finish->(delete $_[0]{rbuf})
885 : $finish->(undef, $ae_error => $_[2]);
886 });
887 $_[0]->on_read (sub { });
888 }
889 }
890 };
891
892 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
893 };
622 894
623 my $connect_cb = sub { 895 my $connect_cb = sub {
624 $state{fh} = shift 896 $state{fh} = shift
625 or do { 897 or do {
626 my $err = "$!"; 898 my $err = "$!";
… …
657# $hdr{connection} = "keep-alive"; 929# $hdr{connection} = "keep-alive";
658# } 930# }
659 931
660 $state{handle}->starttls ("connect") if $rscheme eq "https"; 932 $state{handle}->starttls ("connect") if $rscheme eq "https";
661 933
662 # handle actual, non-tunneled, request
663 my $handle_actual_request = sub {
664 $ae_error = 596; # request phase
665
666 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
667
668 # send request
669 $state{handle}->push_write (
670 "$method $rpath HTTP/1.1\015\012"
671 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
672 . "\015\012"
673 . (delete $arg{body})
674 );
675
676 # return if error occured during push_write()
677 return unless %state;
678
679 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
680
681 # status line and headers
682 $state{read_response} = sub {
683 for ("$_[1]") {
684 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
685
686 /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
687 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
688
689 # 100 Continue handling
690 # should not happen as we don't send expect: 100-continue,
691 # but we handle it just in case.
692 # since we send the request body regardless, if we get an error
693 # we are out of-sync, which we currently do NOT handle correctly.
694 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
695 if $2 eq 100;
696
697 push @pseudo,
698 HTTPVersion => $1,
699 Status => $2,
700 Reason => $3,
701 ;
702
703 my $hdr = parse_hdr
704 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
705
706 %hdr = (%$hdr, @pseudo);
707 }
708
709 # redirect handling
710 # microsoft and other shitheads don't give a shit for following standards,
711 # try to support some common forms of broken Location headers.
712 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
713 $hdr{location} =~ s/^\.\/+//;
714
715 my $url = "$rscheme://$uhost:$uport";
716
717 unless ($hdr{location} =~ s/^\///) {
718 $url .= $upath;
719 $url =~ s/\/[^\/]*$//;
720 }
721
722 $hdr{location} = "$url/$hdr{location}";
723 }
724
725 my $redirect;
726
727 if ($recurse) {
728 my $status = $hdr{Status};
729
730 # industry standard is to redirect POST as GET for
731 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
732 # also, the UA should ask the user for 301 and 307 and POST,
733 # industry standard seems to be to simply follow.
734 # we go with the industry standard.
735 if ($status == 301 or $status == 302 or $status == 303) {
736 # HTTP/1.1 is unclear on how to mutate the method
737 $method = "GET" unless $method eq "HEAD";
738 $redirect = 1;
739 } elsif ($status == 307) {
740 $redirect = 1;
741 }
742 }
743
744 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
745 my $may_keep_alive = $_[3];
746
747 $state{handle}->destroy if $state{handle};
748 %state = ();
749
750 if (defined $_[1]) {
751 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
752 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
753 }
754
755 # set-cookie processing
756 if ($arg{cookie_jar}) {
757 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost;
758 }
759
760 if ($redirect && exists $hdr{location}) {
761 # we ignore any errors, as it is very common to receive
762 # Content-Length != 0 but no actual body
763 # we also access %hdr, as $_[1] might be an erro
764 http_request (
765 $method => $hdr{location},
766 %arg,
767 recurse => $recurse - 1,
768 Redirect => [$_[0], \%hdr],
769 $cb);
770 } else {
771 $cb->($_[0], \%hdr);
772 }
773 };
774
775 $ae_error = 597; # body phase
776
777 my $len = $hdr{"content-length"};
778
779 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
780 $finish->(undef, 598 => "Request cancelled by on_header");
781 } elsif (
782 $hdr{Status} =~ /^(?:1..|204|205|304)$/
783 or $method eq "HEAD"
784 or (defined $len && !$len)
785 ) {
786 # no body
787 $finish->("", undef, undef, 1);
788 } else {
789 # body handling, many different code paths
790 # - no body expected
791 # - want_body_handle
792 # - te chunked
793 # - 2x length known (with or without on_body)
794 # - 2x length not known (with or without on_body)
795 if (!$redirect && $arg{want_body_handle}) {
796 $_[0]->on_eof (undef);
797 $_[0]->on_error (undef);
798 $_[0]->on_read (undef);
799
800 $finish->(delete $state{handle});
801
802 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
803 my $cl = 0;
804 my $body = undef;
805 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
806
807 my $read_chunk; $read_chunk = sub {
808 $_[1] =~ /^([0-9a-fA-F]+)/
809 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
810
811 my $len = hex $1;
812
813 if ($len) {
814 $cl += $len;
815
816 $_[0]->push_read (chunk => $len, sub {
817 $on_body->($_[1], \%hdr)
818 or return $finish->(undef, 598 => "Request cancelled by on_body");
819
820 $_[0]->push_read (line => sub {
821 length $_[1]
822 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
823 $_[0]->push_read (line => $read_chunk);
824 });
825 });
826 } else {
827 $hdr{"content-length"} ||= $cl;
828
829 $_[0]->push_read (line => $qr_nlnl, sub {
830 if (length $_[1]) {
831 for ("$_[1]") {
832 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
833
834 my $hdr = parse_hdr
835 or return $finish->(undef, $ae_error => "Garbled response trailers");
836
837 %hdr = (%hdr, %$hdr);
838 }
839 }
840
841 $finish->($body, undef, undef, 1);
842 });
843 }
844 };
845
846 $_[0]->push_read (line => $read_chunk);
847
848 } elsif ($arg{on_body}) {
849 if ($len) {
850 $_[0]->on_read (sub {
851 $len -= length $_[0]{rbuf};
852
853 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
854 or return $finish->(undef, 598 => "Request cancelled by on_body");
855
856 $len > 0
857 or $finish->("", undef, undef, 1);
858 });
859 } else {
860 $_[0]->on_eof (sub {
861 $finish->("");
862 });
863 $_[0]->on_read (sub {
864 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
865 or $finish->(undef, 598 => "Request cancelled by on_body");
866 });
867 }
868 } else {
869 $_[0]->on_eof (undef);
870
871 if ($len) {
872 $_[0]->on_read (sub {
873 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
874 if $len <= length $_[0]{rbuf};
875 });
876 } else {
877 $_[0]->on_error (sub {
878 ($! == Errno::EPIPE || !$!)
879 ? $finish->(delete $_[0]{rbuf})
880 : $finish->(undef, $ae_error => $_[2]);
881 });
882 $_[0]->on_read (sub { });
883 }
884 }
885 }
886 };
887
888 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
889 };
890
891 # now handle proxy-CONNECT method 934 # now handle proxy-CONNECT method
892 if ($proxy && $uscheme eq "https") { 935 if ($proxy && $uscheme eq "https") {
893 # oh dear, we have to wrap it into a connect request 936 # oh dear, we have to wrap it into a connect request
894 937
895 # maybe re-use $uauthority with patched port? 938 # maybe re-use $uauthority with patched port?
… …
898 $_[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
899 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])" }));
900 943
901 if ($2 == 200) { 944 if ($2 == 200) {
902 $rpath = $upath; 945 $rpath = $upath;
903 &$handle_actual_request; 946 $handle_actual_request->();
904 } else { 947 } else {
905 %state = (); 948 %state = ();
906 $cb->(undef, { @pseudo, Status => $2, Reason => $3 }); 949 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
907 } 950 }
908 }); 951 });
909 } else { 952 } else {
910 &$handle_actual_request; 953 $handle_actual_request->();
911 } 954 }
912 }; 955 };
913 956
914 my $tcp_connect = $arg{tcp_connect} 957 my $tcp_connect = $arg{tcp_connect}
915 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect }; 958 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
916 959
917 $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 });
918
919 }; 961 };
920 962
921 defined wantarray && AnyEvent::Util::guard { %state = () } 963 defined wantarray && AnyEvent::Util::guard { %state = () }
922} 964}
923 965
… …
957Sets the default proxy server to use. The proxy-url must begin with a 999Sets the default proxy server to use. The proxy-url must begin with a
958string of the form C<http://host:port> (optionally C<https:...>), croaks 1000string of the form C<http://host:port> (optionally C<https:...>), croaks
959otherwise. 1001otherwise.
960 1002
961To clear an already-set proxy, use C<undef>. 1003To clear an already-set proxy, use C<undef>.
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 }
962 1043
963=item $date = AnyEvent::HTTP::format_date $timestamp 1044=item $date = AnyEvent::HTTP::format_date $timestamp
964 1045
965Takes 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
966Date (RFC 2616). 1047Date (RFC 2616).

Diff Legend

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