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

… …
152 152
153=item headers => hashref 153=item headers => hashref
154 154
155The request headers to use. Currently, C<http_request> may provide its own 155The request headers to use. Currently, C<http_request> may provide its own
156C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and 156C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
157will provide defaults for C<TE:>, C<Referer:> and C<User-Agent:> (this can 157will provide defaults at least for C<TE:>, C<Referer:> and C<User-Agent:>
158be suppressed by using C<undef> for these headers in which case they won't 158(this can be suppressed by using C<undef> for these headers in which case
159be sent at all). 159they won't be sent at all).
160 160
161=item timeout => $seconds 161=item timeout => $seconds
162 162
163The time-out to use for various stages - each connect attempt will reset 163The time-out to use for various stages - each connect attempt will reset
164the timeout, as will read or write activity, i.e. this is not an overall 164the timeout, as will read or write activity, i.e. this is not an overall
… …
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
198When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
199headers will be set and handled by this module, otherwise they will be
200left untouched.
197 201
198=item tls_ctx => $scheme | $tls_ctx 202=item tls_ctx => $scheme | $tls_ctx
199 203
200Specifies the AnyEvent::TLS context to be used for https connections. This 204Specifies the AnyEvent::TLS context to be used for https connections. This
201parameter follows the same rules as the C<tls_ctx> parameter to 205parameter follows the same rules as the C<tls_ctx> parameter to
… …
448 if (my $jar = $arg{cookie_jar}) { 452 if (my $jar = $arg{cookie_jar}) {
449 %$jar = () if $jar->{version} != 1; 453 %$jar = () if $jar->{version} != 1;
450 454
451 my @cookie; 455 my @cookie;
452 456
453 while (my ($chost, $v) = each %$jar) { 457 while (my ($chost, $paths) = each %$jar) {
454 if ($chost =~ /^\./) { 458 if ($chost =~ /^\./) {
455 next unless $chost eq substr $uhost, -length $chost; 459 next unless $chost eq substr $uhost, -length $chost;
456 } elsif ($chost =~ /\./) { 460 } elsif ($chost =~ /\./) {
457 next unless $chost eq $uhost; 461 next unless $chost eq $uhost;
458 } else { 462 } else {
459 next; 463 next;
460 } 464 }
461 465
462 while (my ($cpath, $v) = each %$v) { 466 while (my ($cpath, $cookies) = each %$paths) {
463 next unless $cpath eq substr $upath, 0, length $cpath; 467 next unless $cpath eq substr $upath, 0, length $cpath;
464 468
465 while (my ($k, $v) = each %$v) { 469 while (my ($cookie, $kv) = each %$cookies) {
466 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
467 my $value = $v->{value}; 479 my $value = $kv->{value};
468 $value =~ s/([\\"])/\\$1/g; 480 $value =~ s/([\\"])/\\$1/g;
469 push @cookie, "$k=\"$value\""; 481 push @cookie, "$cookie=\"$value\"";
470 } 482 }
471 } 483 }
472 } 484 }
473 485
474 $hdr{cookie} = join "; ", @cookie 486 $hdr{cookie} = join "; ", @cookie
… …
642 if ($arg{cookie_jar}) { 654 if ($arg{cookie_jar}) {
643 for ($hdr{"set-cookie"}) { 655 for ($hdr{"set-cookie"}) {
644 # parse NAME=VALUE 656 # parse NAME=VALUE
645 my @kv; 657 my @kv;
646 658
659 while (
660 m{
661 \G\s*
662 (?:
663 expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+)
647 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) { 664 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
665 )
666 }gcxsi
667 ) {
648 my $name = $1; 668 my $name = $2;
649 my $value = $3; 669 my $value = $4;
650 670
651 unless ($value) { 671 unless (defined $name) {
672 # expires
673 $name = "expires";
652 $value = $2; 674 $value = $1;
675 } elsif (!defined $value) {
676 # quoted
677 $value = $3;
653 $value =~ s/\\(.)/$1/gs; 678 $value =~ s/\\(.)/$1/gs;
654 } 679 }
655 680
656 push @kv, $name => $value; 681 push @kv, lc $name, $value;
657 682
658 last unless /\G\s*;/gc; 683 last unless /\G\s*;/gc;
659 } 684 }
660 685
661 last unless @kv; 686 last unless @kv;
662 687
663 my $name = shift @kv; 688 my $name = shift @kv;
664 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"};
665 693
666 my $cdom; 694 my $cdom;
667 my $cpath = (delete $kv{path}) || "/"; 695 my $cpath = (delete $kv{path}) || "/";
668 696
669 if (exists $kv{domain}) { 697 if (exists $kv{domain}) {
… …
899Takes 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
900Date (RFC 2616). 928Date (RFC 2616).
901 929
902=item $timestamp = AnyEvent::HTTP::parse_date $date 930=item $timestamp = AnyEvent::HTTP::parse_date $date
903 931
904Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX 932Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and
905timestamp, or C<undef> if the date cannot be parsed. 933returns the corresponding POSIX timestamp, or C<undef> if the date cannot
934be parsed.
906 935
907=item $AnyEvent::HTTP::MAX_RECURSE 936=item $AnyEvent::HTTP::MAX_RECURSE
908 937
909The default value for the C<recurse> request parameter (default: C<10>). 938The default value for the C<recurse> request parameter (default: C<10>).
910 939
… …
949sub parse_date($) { 978sub parse_date($) {
950 my ($date) = @_; 979 my ($date) = @_;
951 980
952 my ($d, $m, $y, $H, $M, $S); 981 my ($d, $m, $y, $H, $M, $S);
953 982
954 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$/) {
955 # RFC 822/1123, required by RFC 2616 984 # RFC 822/1123, required by RFC 2616 (with " ")
985 # cookie dates (with "-")
986
956 ($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);
957 988
958 } 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$/) {
959 # RFC 850 990 # RFC 850
960 ($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