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.71 by root, Fri Dec 31 20:50:58 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
… …
360 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 364 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
361 365
362 _slot_schedule $_[0]; 366 _slot_schedule $_[0];
363} 367}
364 368
369sub cookie_jar_extract($$$$) {
370 my ($jar, $uscheme, $uhost, $upath) = @_;
371
372 %$jar = () if $jar->{version} != 1;
373
374 my @cookies;
375
376 while (my ($chost, $paths) = each %$jar) {
377 next unless ref $paths;
378
379 if ($chost =~ /^\./) {
380 next unless $chost eq substr $uhost, -length $chost;
381 } elsif ($chost =~ /\./) {
382 next unless $chost eq $uhost;
383 } else {
384 next;
385 }
386
387 while (my ($cpath, $cookies) = each %$paths) {
388 next unless $cpath eq substr $upath, 0, length $cpath;
389
390 while (my ($cookie, $kv) = each %$cookies) {
391 next if $uscheme ne "https" && exists $kv->{secure};
392
393 if (exists $kv->{expires}) {
394 if (AE::now > parse_date ($kv->{expires})) {
395 delete $cookies->{$cookie};
396 next;
397 }
398 }
399
400 my $value = $kv->{value};
401
402 if ($value =~ /[=;,[:space:]]/) {
403 $value =~ s/([\\"])/\\$1/g;
404 $value = "\"$value\"";
405 }
406
407 push @cookies, "$cookie=$value";
408 }
409 }
410 }
411
412 \@cookies
413}
414
365# continue to parse $_ for headers and place them into the arg 415# continue to parse $_ for headers and place them into the arg
366sub parse_hdr() { 416sub parse_hdr() {
367 my %hdr; 417 my %hdr;
368 418
369 # things seen, not parsed: 419 # things seen, not parsed:
… …
444 494
445 $upath =~ s%^/?%/%; 495 $upath =~ s%^/?%/%;
446 496
447 # cookie processing 497 # cookie processing
448 if (my $jar = $arg{cookie_jar}) { 498 if (my $jar = $arg{cookie_jar}) {
449 %$jar = () if $jar->{version} != 1; 499 my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath;
450 500
451 my @cookie;
452
453 while (my ($chost, $v) = each %$jar) {
454 if ($chost =~ /^\./) {
455 next unless $chost eq substr $uhost, -length $chost;
456 } elsif ($chost =~ /\./) {
457 next unless $chost eq $uhost;
458 } else {
459 next;
460 }
461
462 while (my ($cpath, $v) = each %$v) {
463 next unless $cpath eq substr $upath, 0, length $cpath;
464
465 while (my ($k, $v) = each %$v) {
466 next if $uscheme ne "https" && exists $v->{secure};
467 my $value = $v->{value};
468 $value =~ s/([\\"])/\\$1/g;
469 push @cookie, "$k=\"$value\"";
470 }
471 }
472 }
473
474 $hdr{cookie} = join "; ", @cookie 501 $hdr{cookie} = join "; ", @$cookies
475 if @cookie; 502 if @$cookies;
476 } 503 }
477 504
478 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 505 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
479 506
480 if ($proxy) { 507 if ($proxy) {
… …
642 if ($arg{cookie_jar}) { 669 if ($arg{cookie_jar}) {
643 for ($hdr{"set-cookie"}) { 670 for ($hdr{"set-cookie"}) {
644 # parse NAME=VALUE 671 # parse NAME=VALUE
645 my @kv; 672 my @kv;
646 673
674 while (
675 m{
676 \G\s*
677 (?:
678 expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+)
647 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) { 679 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
680 )
681 }gcxsi
682 ) {
648 my $name = $1; 683 my $name = $2;
649 my $value = $3; 684 my $value = $4;
650 685
651 unless ($value) { 686 unless (defined $name) {
687 # expires
688 $name = "expires";
652 $value = $2; 689 $value = $1;
690 } elsif (!defined $value) {
691 # quoted
692 $value = $3;
653 $value =~ s/\\(.)/$1/gs; 693 $value =~ s/\\(.)/$1/gs;
654 } 694 }
655 695
656 push @kv, $name => $value; 696 push @kv, lc $name, $value;
657 697
658 last unless /\G\s*;/gc; 698 last unless /\G\s*;/gc;
659 } 699 }
660 700
661 last unless @kv; 701 last unless @kv;
662 702
663 my $name = shift @kv; 703 my $name = shift @kv;
664 my %kv = (value => shift @kv, @kv); 704 my %kv = (value => shift @kv, @kv);
705
706 $kv{expires} ||= format_date (AE::now + $kv{"max-age"})
707 if exists $kv{"max-age"};
665 708
666 my $cdom; 709 my $cdom;
667 my $cpath = (delete $kv{path}) || "/"; 710 my $cpath = (delete $kv{path}) || "/";
668 711
669 if (exists $kv{domain}) { 712 if (exists $kv{domain}) {
… …
899Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP 942Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
900Date (RFC 2616). 943Date (RFC 2616).
901 944
902=item $timestamp = AnyEvent::HTTP::parse_date $date 945=item $timestamp = AnyEvent::HTTP::parse_date $date
903 946
904Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX 947Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and
905timestamp, or C<undef> if the date cannot be parsed. 948returns the corresponding POSIX timestamp, or C<undef> if the date cannot
949be parsed.
906 950
907=item $AnyEvent::HTTP::MAX_RECURSE 951=item $AnyEvent::HTTP::MAX_RECURSE
908 952
909The default value for the C<recurse> request parameter (default: C<10>). 953The default value for the C<recurse> request parameter (default: C<10>).
910 954
… …
949sub parse_date($) { 993sub parse_date($) {
950 my ($date) = @_; 994 my ($date) = @_;
951 995
952 my ($d, $m, $y, $H, $M, $S); 996 my ($d, $m, $y, $H, $M, $S);
953 997
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$/) { 998 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 999 # RFC 822/1123, required by RFC 2616 (with " ")
1000 # cookie dates (with "-")
1001
956 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6); 1002 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
957 1003
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$/) { 1004 } 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 1005 # RFC 850
960 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6); 1006 ($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