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.74 by root, Fri Dec 31 22:40:54 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
369# extract cookies from jar
370sub cookie_jar_extract($$$$) {
371 my ($jar, $uscheme, $uhost, $upath) = @_;
372
373 %$jar = () if $jar->{version} != 1;
374
375 my @cookies;
376
377 while (my ($chost, $paths) = each %$jar) {
378 next unless ref $paths;
379
380 if ($chost =~ /^\./) {
381 next unless $chost eq substr $uhost, -length $chost;
382 } elsif ($chost =~ /\./) {
383 next unless $chost eq $uhost;
384 } else {
385 next;
386 }
387
388 while (my ($cpath, $cookies) = each %$paths) {
389 next unless $cpath eq substr $upath, 0, length $cpath;
390
391 while (my ($cookie, $kv) = each %$cookies) {
392 next if $uscheme ne "https" && exists $kv->{secure};
393
394 if (exists $kv->{expires}) {
395 if (AE::now > parse_date ($kv->{expires})) {
396 delete $cookies->{$cookie};
397 next;
398 }
399 }
400
401 my $value = $kv->{value};
402
403 if ($value =~ /[=;,[:space:]]/) {
404 $value =~ s/([\\"])/\\$1/g;
405 $value = "\"$value\"";
406 }
407
408 push @cookies, "$cookie=$value";
409 }
410 }
411 }
412
413 \@cookies
414}
415
416# parse set_cookie header into jar
417sub cookie_jar_set_cookie($$$) {
418 my ($jar, $set_cookie, $uhost) = @_;
419
420 for ($set_cookie) {
421 # parse NAME=VALUE
422 my @kv;
423
424 while (
425 m{
426 \G\s*
427 (?:
428 expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+)
429 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
430 )
431 }gcxsi
432 ) {
433 my $name = $2;
434 my $value = $4;
435
436 unless (defined $name) {
437 # expires
438 $name = "expires";
439 $value = $1;
440 } elsif (!defined $value) {
441 # quoted
442 $value = $3;
443 $value =~ s/\\(.)/$1/gs;
444 }
445
446 push @kv, lc $name, $value;
447
448 last unless /\G\s*;/gc;
449 }
450
451 last unless @kv;
452
453 my $name = shift @kv;
454 my %kv = (value => shift @kv, @kv);
455
456 $kv{expires} ||= format_date (AE::now + $kv{"max-age"})
457 if exists $kv{"max-age"};
458
459 my $cdom;
460 my $cpath = (delete $kv{path}) || "/";
461
462 if (exists $kv{domain}) {
463 $cdom = delete $kv{domain};
464
465 $cdom =~ s/^\.?/./; # make sure it starts with a "."
466
467 next if $cdom =~ /\.$/;
468
469 # this is not rfc-like and not netscape-like. go figure.
470 my $ndots = $cdom =~ y/.//;
471 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
472 } else {
473 $cdom = $uhost;
474 }
475
476 # store it
477 $jar->{version} = 1;
478 $jar->{$cdom}{$cpath}{$name} = \%kv;
479
480 redo if /\G\s*,/gc;
481 }
482}
483
365# continue to parse $_ for headers and place them into the arg 484# continue to parse $_ for headers and place them into the arg
366sub parse_hdr() { 485sub parse_hdr() {
367 my %hdr; 486 my %hdr;
368 487
369 # things seen, not parsed: 488 # things seen, not parsed:
… …
444 563
445 $upath =~ s%^/?%/%; 564 $upath =~ s%^/?%/%;
446 565
447 # cookie processing 566 # cookie processing
448 if (my $jar = $arg{cookie_jar}) { 567 if (my $jar = $arg{cookie_jar}) {
449 %$jar = () if $jar->{version} != 1; 568 my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath;
450 569
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 570 $hdr{cookie} = join "; ", @$cookies
475 if @cookie; 571 if @$cookies;
476 } 572 }
477 573
478 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 574 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
479 575
480 if ($proxy) { 576 if ($proxy) {
… …
626 $redirect = 1; 722 $redirect = 1;
627 } 723 }
628 } 724 }
629 725
630 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 726 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
631 my $keepalive = pop; 727 my $may_keep_alive = $_[3];
632 728
633 $state{handle}->destroy if $state{handle}; 729 $state{handle}->destroy if $state{handle};
634 %state = (); 730 %state = ();
635 731
636 if (defined $_[1]) { 732 if (defined $_[1]) {
… …
638 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2]; 734 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
639 } 735 }
640 736
641 # set-cookie processing 737 # set-cookie processing
642 if ($arg{cookie_jar}) { 738 if ($arg{cookie_jar}) {
643 for ($hdr{"set-cookie"}) { 739 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost;
644 # parse NAME=VALUE
645 my @kv;
646
647 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
648 my $name = $1;
649 my $value = $3;
650
651 unless ($value) {
652 $value = $2;
653 $value =~ s/\\(.)/$1/gs;
654 }
655
656 push @kv, $name => $value;
657
658 last unless /\G\s*;/gc;
659 }
660
661 last unless @kv;
662
663 my $name = shift @kv;
664 my %kv = (value => shift @kv, @kv);
665
666 my $cdom;
667 my $cpath = (delete $kv{path}) || "/";
668
669 if (exists $kv{domain}) {
670 $cdom = delete $kv{domain};
671
672 $cdom =~ s/^\.?/./; # make sure it starts with a "."
673
674 next if $cdom =~ /\.$/;
675
676 # this is not rfc-like and not netscape-like. go figure.
677 my $ndots = $cdom =~ y/.//;
678 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
679 } else {
680 $cdom = $uhost;
681 }
682
683 # store it
684 $arg{cookie_jar}{version} = 1;
685 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
686
687 redo if /\G\s*,/gc;
688 }
689 } 740 }
690 741
691 if ($redirect && exists $hdr{location}) { 742 if ($redirect && exists $hdr{location}) {
692 # we ignore any errors, as it is very common to receive 743 # we ignore any errors, as it is very common to receive
693 # Content-Length != 0 but no actual body 744 # Content-Length != 0 but no actual body
… …
899Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP 950Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
900Date (RFC 2616). 951Date (RFC 2616).
901 952
902=item $timestamp = AnyEvent::HTTP::parse_date $date 953=item $timestamp = AnyEvent::HTTP::parse_date $date
903 954
904Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX 955Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and
905timestamp, or C<undef> if the date cannot be parsed. 956returns the corresponding POSIX timestamp, or C<undef> if the date cannot
957be parsed.
906 958
907=item $AnyEvent::HTTP::MAX_RECURSE 959=item $AnyEvent::HTTP::MAX_RECURSE
908 960
909The default value for the C<recurse> request parameter (default: C<10>). 961The default value for the C<recurse> request parameter (default: C<10>).
910 962
… …
949sub parse_date($) { 1001sub parse_date($) {
950 my ($date) = @_; 1002 my ($date) = @_;
951 1003
952 my ($d, $m, $y, $H, $M, $S); 1004 my ($d, $m, $y, $H, $M, $S);
953 1005
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$/) { 1006 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 1007 # RFC 822/1123, required by RFC 2616 (with " ")
1008 # cookie dates (with "-")
1009
956 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6); 1010 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
957 1011
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$/) { 1012 } 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 1013 # RFC 850
960 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6); 1014 ($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