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.71 by root, Fri Dec 31 20:50:58 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
… …
364 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 364 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
365 365
366 _slot_schedule $_[0]; 366 _slot_schedule $_[0];
367} 367}
368 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
369# continue to parse $_ for headers and place them into the arg 415# continue to parse $_ for headers and place them into the arg
370sub parse_hdr() { 416sub parse_hdr() {
371 my %hdr; 417 my %hdr;
372 418
373 # things seen, not parsed: 419 # things seen, not parsed:
… …
448 494
449 $upath =~ s%^/?%/%; 495 $upath =~ s%^/?%/%;
450 496
451 # cookie processing 497 # cookie processing
452 if (my $jar = $arg{cookie_jar}) { 498 if (my $jar = $arg{cookie_jar}) {
453 %$jar = () if $jar->{version} != 1; 499 my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath;
454 500
455 my @cookie;
456
457 while (my ($chost, $v) = each %$jar) {
458 if ($chost =~ /^\./) {
459 next unless $chost eq substr $uhost, -length $chost;
460 } elsif ($chost =~ /\./) {
461 next unless $chost eq $uhost;
462 } else {
463 next;
464 }
465
466 while (my ($cpath, $v) = each %$v) {
467 next unless $cpath eq substr $upath, 0, length $cpath;
468
469 while (my ($k, $v) = each %$v) {
470 next if $uscheme ne "https" && exists $v->{secure};
471 my $value = $v->{value};
472 $value =~ s/([\\"])/\\$1/g;
473 push @cookie, "$k=\"$value\"";
474 }
475 }
476 }
477
478 $hdr{cookie} = join "; ", @cookie 501 $hdr{cookie} = join "; ", @$cookies
479 if @cookie; 502 if @$cookies;
480 } 503 }
481 504
482 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 505 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
483 506
484 if ($proxy) { 507 if ($proxy) {
… …
646 if ($arg{cookie_jar}) { 669 if ($arg{cookie_jar}) {
647 for ($hdr{"set-cookie"}) { 670 for ($hdr{"set-cookie"}) {
648 # parse NAME=VALUE 671 # parse NAME=VALUE
649 my @kv; 672 my @kv;
650 673
674 while (
675 m{
676 \G\s*
677 (?:
678 expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+)
651 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) { 679 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
680 )
681 }gcxsi
682 ) {
652 my $name = $1; 683 my $name = $2;
653 my $value = $3; 684 my $value = $4;
654 685
655 unless ($value) { 686 unless (defined $name) {
687 # expires
688 $name = "expires";
656 $value = $2; 689 $value = $1;
690 } elsif (!defined $value) {
691 # quoted
692 $value = $3;
657 $value =~ s/\\(.)/$1/gs; 693 $value =~ s/\\(.)/$1/gs;
658 } 694 }
659 695
660 push @kv, $name => $value; 696 push @kv, lc $name, $value;
661 697
662 last unless /\G\s*;/gc; 698 last unless /\G\s*;/gc;
663 } 699 }
664 700
665 last unless @kv; 701 last unless @kv;
666 702
667 my $name = shift @kv; 703 my $name = shift @kv;
668 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"};
669 708
670 my $cdom; 709 my $cdom;
671 my $cpath = (delete $kv{path}) || "/"; 710 my $cpath = (delete $kv{path}) || "/";
672 711
673 if (exists $kv{domain}) { 712 if (exists $kv{domain}) {
… …
903Takes 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
904Date (RFC 2616). 943Date (RFC 2616).
905 944
906=item $timestamp = AnyEvent::HTTP::parse_date $date 945=item $timestamp = AnyEvent::HTTP::parse_date $date
907 946
908Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX 947Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and
909timestamp, or C<undef> if the date cannot be parsed. 948returns the corresponding POSIX timestamp, or C<undef> if the date cannot
949be parsed.
910 950
911=item $AnyEvent::HTTP::MAX_RECURSE 951=item $AnyEvent::HTTP::MAX_RECURSE
912 952
913The default value for the C<recurse> request parameter (default: C<10>). 953The default value for the C<recurse> request parameter (default: C<10>).
914 954
… …
953sub parse_date($) { 993sub parse_date($) {
954 my ($date) = @_; 994 my ($date) = @_;
955 995
956 my ($d, $m, $y, $H, $M, $S); 996 my ($d, $m, $y, $H, $M, $S);
957 997
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$/) { 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$/) {
959 # RFC 822/1123, required by RFC 2616 999 # RFC 822/1123, required by RFC 2616 (with " ")
1000 # cookie dates (with "-")
1001
960 ($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);
961 1003
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$/) { 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$/) {
963 # RFC 850 1005 # RFC 850
964 ($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