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.69 by root, Fri Dec 31 19:32:47 2010 UTC vs.
Revision 1.70 by root, Fri Dec 31 20:31:47 2010 UTC

… …
183 183
184Passing this parameter enables (simplified) cookie-processing, loosely 184Passing this parameter enables (simplified) cookie-processing, loosely
185based on the original netscape specification. 185based on the original netscape specification.
186 186
187The C<$hash_ref> must be an (initially empty) hash reference which will 187The C<$hash_ref> must be an (initially empty) hash reference which will
188get updated automatically. It is possible to save the cookie_jar to 188get updated automatically. It is possible to save the cookie jar to
189persistent storage with something like JSON or Storable, but this is not 189persistent storage with something like JSON or Storable, but this is not
190recommended, as expiry times are currently being ignored. 190recommended, as session-only cookies might survive longer than expected.
191 191
192Note that this cookie implementation is not of very high quality, nor 192Note that this cookie implementation is not meant to be complete. If
193meant to be complete. If you want complete cookie management you have to 193you want complete cookie management you have to do that on your
194do that on your own. C<cookie_jar> is meant as a quick fix to get some 194own. C<cookie_jar> is meant as a quick fix to get some cookie-using sites
195cookie-using sites working. Cookies are a privacy disaster, do not use 195working. Cookies are a privacy disaster, do not use them unless required
196them unless required to. 196to.
197 197
198When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:> 198When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
199headers will be ste and handled by this module, otherwise they will be 199headers will be set and handled by this module, otherwise they will be
200left untouched. 200left untouched.
201 201
202=item tls_ctx => $scheme | $tls_ctx 202=item tls_ctx => $scheme | $tls_ctx
203 203
204Specifies the AnyEvent::TLS context to be used for https connections. This 204Specifies the AnyEvent::TLS context to be used for https connections. This
… …
452 if (my $jar = $arg{cookie_jar}) { 452 if (my $jar = $arg{cookie_jar}) {
453 %$jar = () if $jar->{version} != 1; 453 %$jar = () if $jar->{version} != 1;
454 454
455 my @cookie; 455 my @cookie;
456 456
457 while (my ($chost, $v) = each %$jar) { 457 while (my ($chost, $paths) = each %$jar) {
458 if ($chost =~ /^\./) { 458 if ($chost =~ /^\./) {
459 next unless $chost eq substr $uhost, -length $chost; 459 next unless $chost eq substr $uhost, -length $chost;
460 } elsif ($chost =~ /\./) { 460 } elsif ($chost =~ /\./) {
461 next unless $chost eq $uhost; 461 next unless $chost eq $uhost;
462 } else { 462 } else {
463 next; 463 next;
464 } 464 }
465 465
466 while (my ($cpath, $v) = each %$v) { 466 while (my ($cpath, $cookies) = each %$paths) {
467 next unless $cpath eq substr $upath, 0, length $cpath; 467 next unless $cpath eq substr $upath, 0, length $cpath;
468 468
469 while (my ($k, $v) = each %$v) { 469 while (my ($cookie, $kv) = each %$cookies) {
470 next if $uscheme ne "https" && exists $v->{secure}; 470 next if $uscheme ne "https" && exists $kv->{secure};
471
472 if (exists $kv->{expires}) {
473 if (AE::now > parse_date ($kv->{expires})) {
474 delete $cookies->{$cookie};
475 next;
476 }
477 }
478
471 my $value = $v->{value}; 479 my $value = $kv->{value};
472 $value =~ s/([\\"])/\\$1/g; 480 $value =~ s/([\\"])/\\$1/g;
473 push @cookie, "$k=\"$value\""; 481 push @cookie, "$cookie=\"$value\"";
474 } 482 }
475 } 483 }
476 } 484 }
477 485
478 $hdr{cookie} = join "; ", @cookie 486 $hdr{cookie} = join "; ", @cookie
… …
646 if ($arg{cookie_jar}) { 654 if ($arg{cookie_jar}) {
647 for ($hdr{"set-cookie"}) { 655 for ($hdr{"set-cookie"}) {
648 # parse NAME=VALUE 656 # parse NAME=VALUE
649 my @kv; 657 my @kv;
650 658
659 while (
660 m{
661 \G\s*
662 (?:
663 expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+)
651 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) { 664 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
665 )
666 }gcxsi
667 ) {
652 my $name = $1; 668 my $name = $2;
653 my $value = $3; 669 my $value = $4;
654 670
655 unless ($value) { 671 unless (defined $name) {
672 # expires
673 $name = "expires";
656 $value = $2; 674 $value = $1;
675 } elsif (!defined $value) {
676 # quoted
677 $value = $3;
657 $value =~ s/\\(.)/$1/gs; 678 $value =~ s/\\(.)/$1/gs;
658 } 679 }
659 680
660 push @kv, $name => $value; 681 push @kv, lc $name, $value;
661 682
662 last unless /\G\s*;/gc; 683 last unless /\G\s*;/gc;
663 } 684 }
664 685
665 last unless @kv; 686 last unless @kv;
666 687
667 my $name = shift @kv; 688 my $name = shift @kv;
668 my %kv = (value => shift @kv, @kv); 689 my %kv = (value => shift @kv, @kv);
690
691 $kv{expires} ||= format_date (AE::now + $kv{"max-age"})
692 if exists $kv{"max-age"};
669 693
670 my $cdom; 694 my $cdom;
671 my $cpath = (delete $kv{path}) || "/"; 695 my $cpath = (delete $kv{path}) || "/";
672 696
673 if (exists $kv{domain}) { 697 if (exists $kv{domain}) {
… …
903Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP 927Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
904Date (RFC 2616). 928Date (RFC 2616).
905 929
906=item $timestamp = AnyEvent::HTTP::parse_date $date 930=item $timestamp = AnyEvent::HTTP::parse_date $date
907 931
908Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX 932Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and
909timestamp, or C<undef> if the date cannot be parsed. 933returns the corresponding POSIX timestamp, or C<undef> if the date cannot
934be parsed.
910 935
911=item $AnyEvent::HTTP::MAX_RECURSE 936=item $AnyEvent::HTTP::MAX_RECURSE
912 937
913The default value for the C<recurse> request parameter (default: C<10>). 938The default value for the C<recurse> request parameter (default: C<10>).
914 939
… …
953sub parse_date($) { 978sub parse_date($) {
954 my ($date) = @_; 979 my ($date) = @_;
955 980
956 my ($d, $m, $y, $H, $M, $S); 981 my ($d, $m, $y, $H, $M, $S);
957 982
958 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$/) { 983 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$/) {
959 # RFC 822/1123, required by RFC 2616 984 # RFC 822/1123, required by RFC 2616 (with " ")
985 # cookie dates (with "-")
986
960 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6); 987 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
961 988
962 } 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$/) { 989 } 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$/) {
963 # RFC 850 990 # RFC 850
964 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6); 991 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);

Diff Legend

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