[ViewVC] Diff of: cvs/AnyEvent-HTTP/HTTP.pm

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.69 by root, Fri Dec 31 19:32:47 2010 UTC vs.
Revision 1.87 by root, Sun Jan 2 08:51:53 2011 UTC

 =cut
 package AnyEvent::HTTP;
-use strict;
+use common::sense;
-no warnings;
 use Errno ();
 use AnyEvent 5.0 ();
 use AnyEvent::Util ();
 If the server sends a header multiple times, then their contents will be
 joined together with a comma (C<,>), as per the HTTP spec.
 If an internal error occurs, such as not being able to resolve a hostname,
-then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<59x>
+then C<$data> will be C<undef>, C<< $headers->{Status} >> will be
-(usually C<599>) and the C<Reason> pseudo-header will contain an error
+C<590>-C<599> and the C<Reason> pseudo-header will contain an error
-message.
+message. Currently the following status codes are used:
+=over 4
+=item 595 - errors during connection etsbalishment, proxy handshake.
+=item 596 - errors during TLS negotiation, request sending and header processing.
+=item 597 - errors during body receiving or processing.
+=item 598 - user aborted request via C<on_header> or C<on_body>.
+=item 599 - other, usually nonretryable, errors (garbled URL etc.).
+=back
 A typical callback might look like this:
    sub {
       my ($body, $hdr) = @_;
 =item cookie_jar => $hash_ref
 Passing this parameter enables (simplified) cookie-processing, loosely
 based on the original netscape specification.
-The C<$hash_ref> must be an (initially empty) hash reference which will
+The C<$hash_ref> must be an (initially empty) hash reference which
-get updated automatically. It is possible to save the cookie_jar to
+will get updated automatically. It is possible to save the cookie jar
-persistent storage with something like JSON or Storable, but this is not
+to persistent storage with something like JSON or Storable - see the
-recommended, as expiry times are currently being ignored.
+C<AnyEvent::HTTP::cookie_jar_expire> function if you wish to remove
+expired or session-only cookies, and also for documentation on the format
+of the cookie jar.
-Note that this cookie implementation is not of very high quality, nor
+Note that this cookie implementation is not meant to be complete. If
-meant to be complete. If you want complete cookie management you have to
+you want complete cookie management you have to do that on your
-do that on your own. C<cookie_jar> is meant as a quick fix to get some
+own. C<cookie_jar> is meant as a quick fix to get most cookie-using sites
-cookie-using sites working. Cookies are a privacy disaster, do not use
+working. Cookies are a privacy disaster, do not use them unless required
-them unless required to.
+to.
 When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
-headers will be ste and handled by this module, otherwise they will be
+headers will be set and handled by this module, otherwise they will be
 left untouched.
 =item tls_ctx => $scheme | $tls_ctx
 Specifies the AnyEvent::TLS context to be used for https connections. This
    push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
    _slot_schedule $_[0];
 }
+#############################################################################
+# expire cookies
+sub cookie_jar_expire($;$) {
+   my ($jar, $session_end) = @_;
+   %$jar = () if $jar->{version} != 1;
+   my $anow = AE::now;
+   while (my ($chost, $paths) = each %$jar) {
+      next unless ref $paths;
+      while (my ($cpath, $cookies) = each %$paths) {
+         while (my ($cookie, $kv) = each %$cookies) {
+            if (exists $kv->{_expires}) {
+               delete $cookies->{$cookie}
+                  if $anow > $kv->{_expires};
+            } elsif ($session_end) {
+               delete $cookies->{$cookie};
+            }
+         }
+         delete $paths->{$cpath}
+            unless %$cookies;
+      }
+      delete $jar->{$chost}
+         unless %$paths;
+   }
+}
+# extract cookies from jar
+sub cookie_jar_extract($$$$) {
+   my ($jar, $uscheme, $uhost, $upath) = @_;
+   %$jar = () if $jar->{version} != 1;
+   my @cookies;
+   while (my ($chost, $paths) = each %$jar) {
+      next unless ref $paths;
+      if ($chost =~ /^\./) {
+         next unless $chost eq substr $uhost, -length $chost;
+      } elsif ($chost =~ /\./) {
+         next unless $chost eq $uhost;
+      } else {
+         next;
+      }
+      while (my ($cpath, $cookies) = each %$paths) {
+         next unless $cpath eq substr $upath, 0, length $cpath;
+         while (my ($cookie, $kv) = each %$cookies) {
+            next if $uscheme ne "https" && exists $kv->{secure};
+            if (exists $kv->{_expires} and AE::now > $kv->{_expires}) {
+               delete $cookies->{$cookie};
+               next;
+            }
+            my $value = $kv->{value};
+            if ($value =~ /[=;,[:space:]]/) {
+               $value =~ s/([\\"])/\\$1/g;
+               $value = "\"$value\"";
+            }
+            push @cookies, "$cookie=$value";
+         }
+      }
+   }
+   \@cookies
+}
+# parse set_cookie header into jar
+sub cookie_jar_set_cookie($$$$) {
+   my ($jar, $set_cookie, $uhost, $date) = @_;
+   my $anow = int AE::now;
+   my $snow; # server-now
+   for ($set_cookie) {
+      # parse NAME=VALUE
+      my @kv;
+      # expires is not http-compliant in the original cookie-spec,
+      # we support the official date format and some extensions
+      while (
+         m{
+            \G\s*
+            (?:
+               expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+)
+               | ([^=;,[:space:]]+) (?: \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) ) )?
+            )
+         }gcxsi
+      ) {
+         my $name = $2;
+         my $value = $4;
+         if (defined $1) {
+            # expires
+            $name  = "expires";
+            $value = $1;
+         } elsif (defined $3) {
+            # quoted
+            $value = $3;
+            $value =~ s/\\(.)/$1/gs;
+         }
+         push @kv, lc $name, $value;
+         last unless /\G\s*;/gc;
+      }
+      last unless @kv;
+      my $name = shift @kv;
+      my %kv = (value => shift @kv, @kv);
+      if (exists $kv{"max-age"}) {
+         $kv{_expires} = $anow + delete $kv{"max-age"};
+      } elsif (exists $kv{expires}) {
+         $snow ||= parse_date ($date) || $anow;
+         $kv{_expires} = $anow + (parse_date (delete $kv{expires}) - $snow);
+      } else {
+         delete $kv{_expires};
+      }
+      my $cdom;
+      my $cpath = (delete $kv{path}) || "/";
+      if (exists $kv{domain}) {
+         $cdom = delete $kv{domain};
+         $cdom =~ s/^\.?/./; # make sure it starts with a "."
+         next if $cdom =~ /\.$/;
+         # this is not rfc-like and not netscape-like. go figure.
+         my $ndots = $cdom =~ y/.//;
+         next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
+      } else {
+         $cdom = $uhost;
+      }
+      # store it
+      $jar->{version} = 1;
+      $jar->{lc $cdom}{$cpath}{$name} = \%kv;
+      redo if /\G\s*,/gc;
+   }
+}
 # continue to parse $_ for headers and place them into the arg
 sub parse_hdr() {
    my %hdr;
    # things seen, not parsed:
              : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
    $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
       or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
-   my $uhost = $1;
+   my $uhost = lc $1;
    $uport = $2 if defined $2;
    $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
       unless exists $hdr{host};
    $upath =~ s%^/?%/%;
    # cookie processing
    if (my $jar = $arg{cookie_jar}) {
-      %$jar = () if $jar->{version} != 1;
+      my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath;
-      my @cookie;
-      while (my ($chost, $v) = each %$jar) {
-         if ($chost =~ /^\./) {
-            next unless $chost eq substr $uhost, -length $chost;
-         } elsif ($chost =~ /\./) {
-            next unless $chost eq $uhost;
-         } else {
-            next;
-         }
-         while (my ($cpath, $v) = each %$v) {
-            next unless $cpath eq substr $upath, 0, length $cpath;
-            while (my ($k, $v) = each %$v) {
-               next if $uscheme ne "https" && exists $v->{secure};
-               my $value = $v->{value};
-               $value =~ s/([\\"])/\\$1/g;
-               push @cookie, "$k=\"$value\"";
-            }
-         }
-      }
-      $hdr{cookie} = join "; ", @cookie
+      $hdr{cookie} = join "; ", @$cookies
-         if @cookie;
+         if @$cookies;
    }
    my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
    if ($proxy) {
       $rscheme = "http" unless defined $rscheme;
       # don't support https requests over https-proxy transport,
       # can't be done with tls as spec'ed, unless you double-encrypt.
       $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
+      $rhost   = lc $rhost;
+      $rscheme = lc $rscheme;
    } else {
       ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
    }
    # leave out fragment and query string, just a heuristic
    $hdr{"user-agent"} = $USERAGENT                     unless exists $hdr{"user-agent"};
    $hdr{"content-length"} = length $arg{body}
       if length $arg{body} || $method ne "GET";
-   $hdr{connection} = "close TE"; #1.1
+   $hdr{connection} = "close Te"; #1.1
    $hdr{te}         = "trailers" unless exists $hdr{te}; #1.1
    my %state = (connect_guard => 1);
    _get_slot $uhost, sub {
       $state{slot_guard} = shift;
       return unless $state{connect_guard};
+      my $ae_error = 595; # connecting
+      # handle actual, non-tunneled, request
+      my $handle_actual_request = sub {
+         $ae_error = 596; # request phase
+         $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
+         # send request
+         $state{handle}->push_write (
+            "$method $rpath HTTP/1.1\015\012"
+            . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
+            . "\015\012"
+            . (delete $arg{body})
+         );
+         # return if error occured during push_write()
+         return unless %state;
+         %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
+         # status line and headers
+         $state{read_response} = sub {
+            for ("$_[1]") {
+               y/\015//d; # weed out any \015, as they show up in the weirdest of places.
+               /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
+                  or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
+               # 100 Continue handling
+               # should not happen as we don't send expect: 100-continue,
+               # but we handle it just in case.
+               # since we send the request body regardless, if we get an error
+               # we are out of-sync, which we currently do NOT handle correctly.
+               return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
+                  if $2 eq 100;
+               push @pseudo,
+                  HTTPVersion => $1,
+                  Status      => $2,
+                  Reason      => $3,
+               ;
+               my $hdr = parse_hdr
+                  or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
+               %hdr = (%$hdr, @pseudo);
+            }
+            # redirect handling
+            # microsoft and other shitheads don't give a shit for following standards,
+            # try to support some common forms of broken Location headers.
+            if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
+               $hdr{location} =~ s/^\.\/+//;
+               my $url = "$rscheme://$uhost:$uport";
+               unless ($hdr{location} =~ s/^\///) {
+                  $url .= $upath;
+                  $url =~ s/\/[^\/]*$//;
+               }
+               $hdr{location} = "$url/$hdr{location}";
+            }
+            my $redirect;
+            if ($recurse) {
+               my $status = $hdr{Status};
+               # industry standard is to redirect POST as GET for
+               # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
+               # also, the UA should ask the user for 301 and 307 and POST,
+               # industry standard seems to be to simply follow.
+               # we go with the industry standard.
+               if ($status == 301 or $status == 302 or $status == 303) {
+                  # HTTP/1.1 is unclear on how to mutate the method
+                  $method = "GET" unless $method eq "HEAD";
+                  $redirect = 1;
+               } elsif ($status == 307) {
+                  $redirect = 1;
+               }
+            }
+            my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
+               my $may_keep_alive = $_[3];
+               $state{handle}->destroy if $state{handle};
+               %state = ();
+               if (defined $_[1]) {
+                  $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
+                  $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
+               }
+               # set-cookie processing
+               if ($arg{cookie_jar}) {
+                  cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost, $hdr{date};
+               }
+               if ($redirect && exists $hdr{location}) {
+                  # we ignore any errors, as it is very common to receive
+                  # Content-Length != 0 but no actual body
+                  # we also access %hdr, as $_[1] might be an erro
+                  http_request (
+                     $method  => $hdr{location},
+                     %arg,
+                     recurse  => $recurse - 1,
+                     Redirect => [$_[0], \%hdr],
+                     $cb);
+               } else {
+                  $cb->($_[0], \%hdr);
+               }
+            };
+            $ae_error = 597; # body phase
+            my $len = $hdr{"content-length"};
+            # body handling, many different code paths
+            # - no body expected
+            # - want_body_handle
+            # - te chunked
+            # - 2x length known (with or without on_body)
+            # - 2x length not known (with or without on_body)
+            if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
+               $finish->(undef, 598 => "Request cancelled by on_header");
+            } elsif (
+               $hdr{Status} =~ /^(?:1..|204|205|304)$/
+               or $method eq "HEAD"
+               or (defined $len && $len == 0) # == 0, not !, because "0   " is true
+            ) {
+               # no body
+               $finish->("", undef, undef, 1);
+            } elsif (!$redirect && $arg{want_body_handle}) {
+               $_[0]->on_eof   (undef);
+               $_[0]->on_error (undef);
+               $_[0]->on_read  (undef);
+               $finish->(delete $state{handle});
+            } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
+               my $cl = 0;
+               my $body = undef;
+               my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
+               $state{read_chunk} = sub {
+                  $_[1] =~ /^([0-9a-fA-F]+)/
+                     or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
+                  my $len = hex $1;
+                  if ($len) {
+                     $cl += $len;
+                     $_[0]->push_read (chunk => $len, sub {
+                        $on_body->($_[1], \%hdr)
+                           or return $finish->(undef, 598 => "Request cancelled by on_body");
+                        $_[0]->push_read (line => sub {
+                           length $_[1]
+                              and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
+                           $_[0]->push_read (line => $state{read_chunk});
+                        });
+                     });
+                  } else {
+                     $hdr{"content-length"} ||= $cl;
+                     $_[0]->push_read (line => $qr_nlnl, sub {
+                        if (length $_[1]) {
+                           for ("$_[1]") {
+                              y/\015//d; # weed out any \015, as they show up in the weirdest of places.
+                              my $hdr = parse_hdr
+                                 or return $finish->(undef, $ae_error => "Garbled response trailers");
+                              %hdr = (%hdr, %$hdr);
+                           }
+                        }
+                        $finish->($body, undef, undef, 1);
+                     });
+                  }
+               };
+               $_[0]->push_read (line => $state{read_chunk});
+            } elsif ($arg{on_body}) {
+               if (defined $len) {
+                  $_[0]->on_read (sub {
+                     $len -= length $_[0]{rbuf};
+                     $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
+                        or return $finish->(undef, 598 => "Request cancelled by on_body");
+                     $len > 0
+                        or $finish->("", undef, undef, 1);
+                  });
+               } else {
+                  $_[0]->on_eof (sub {
+                     $finish->("");
+                  });
+                  $_[0]->on_read (sub {
+                     $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
+                        or $finish->(undef, 598 => "Request cancelled by on_body");
+                  });
+               }
+            } else {
+               $_[0]->on_eof (undef);
+               if (defined $len) {
+                  $_[0]->on_read (sub {
+                     $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
+                        if $len <= length $_[0]{rbuf};
+                  });
+               } else {
+                  $_[0]->on_error (sub {
+                     ($! == Errno::EPIPE || !$!)
+                        ? $finish->(delete $_[0]{rbuf})
+                        : $finish->(undef, $ae_error => $_[2]);
+                  });
+                  $_[0]->on_read (sub { });
+               }
+            }
+         };
+         $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
+      };
       my $connect_cb = sub {
          $state{fh} = shift
             or do {
                my $err = "$!";
                %state = ();
-               return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
+               return $cb->(undef, { @pseudo, Status => $ae_error, Reason => $err });
             };
-         pop; # free memory, save a tree
          return unless delete $state{connect_guard};
          # get handle
          $state{handle} = new AnyEvent::Handle
             tls_ctx  => $arg{tls_ctx},
             # these need to be reconfigured on keepalive handles
             timeout  => $timeout,
             on_error => sub {
                %state = ();
-               $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
+               $cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] });
             },
             on_eof   => sub {
                %state = ();
-               $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
+               $cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" });
             },
          ;
          # limit the number of persistent connections
          # keepalive not yet supported
 #            $hdr{connection} = "keep-alive";
 #         }
          $state{handle}->starttls ("connect") if $rscheme eq "https";
-         # handle actual, non-tunneled, request
-         my $handle_actual_request = sub {
-            $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
-            # send request
-            $state{handle}->push_write (
-               "$method $rpath HTTP/1.1\015\012"
-               . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
-               . "\015\012"
-               . (delete $arg{body})
-            );
-            # return if error occured during push_write()
-            return unless %state;
-            %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
-            # status line and headers
-            $state{read_response} = sub {
-               for ("$_[1]") {
-                  y/\015//d; # weed out any \015, as they show up in the weirdest of places.
-                  /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
-                     or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
-                  # 100 Continue handling
-                  # should not happen as we don't send expect: 100-continue,
-                  # but we handle it just in case.
-                  # since we send the request body regardless, if we get an error
-                  # we are out of-sync, which we currently do NOT handle correctly.
-                  return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
-                     if $2 eq 100;
-                  push @pseudo,
-                     HTTPVersion => $1,
-                     Status      => $2,
-                     Reason      => $3,
-                  ;
-                  my $hdr = parse_hdr
-                     or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
-                  %hdr = (%$hdr, @pseudo);
-               }
-               # redirect handling
-               # microsoft and other shitheads don't give a shit for following standards,
-               # try to support some common forms of broken Location headers.
-               if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
-                  $hdr{location} =~ s/^\.\/+//;
-                  my $url = "$rscheme://$uhost:$uport";
-                  unless ($hdr{location} =~ s/^\///) {
-                     $url .= $upath;
-                     $url =~ s/\/[^\/]*$//;
-                  }
-                  $hdr{location} = "$url/$hdr{location}";
-               }
-               my $redirect;
-               if ($recurse) {
-                  my $status = $hdr{Status};
-                  # industry standard is to redirect POST as GET for
-                  # 301, 302 and 303, in contrast to http/1.0 and 1.1.
-                  # also, the UA should ask the user for 301 and 307 and POST,
-                  # industry standard seems to be to simply follow.
-                  # we go with the industry standard.
-                  if ($status == 301 or $status == 302 or $status == 303) {
-                     # HTTP/1.1 is unclear on how to mutate the method
-                     $method = "GET" unless $method eq "HEAD";
-                     $redirect = 1;
-                  } elsif ($status == 307) {
-                     $redirect = 1;
-                  }
-               }
-               my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
-                  my $keepalive = pop;
-                  $state{handle}->destroy if $state{handle};
-                  %state = ();
-                  if (defined $_[1]) {
-                     $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
-                     $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
-                  }
-                  # set-cookie processing
-                  if ($arg{cookie_jar}) {
-                     for ($hdr{"set-cookie"}) {
-                        # parse NAME=VALUE
-                        my @kv;
-                        while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
-                           my $name = $1;
-                           my $value = $3;
-                           unless ($value) {
-                              $value = $2;
-                              $value =~ s/\\(.)/$1/gs;
-                           }
-                           push @kv, $name => $value;
-                           last unless /\G\s*;/gc;
-                        }
-                        last unless @kv;
-                        my $name = shift @kv;
-                        my %kv = (value => shift @kv, @kv);
-                        my $cdom;
-                        my $cpath = (delete $kv{path}) || "/";
-                        if (exists $kv{domain}) {
-                           $cdom = delete $kv{domain};
-                           $cdom =~ s/^\.?/./; # make sure it starts with a "."
-                           next if $cdom =~ /\.$/;
-                           # this is not rfc-like and not netscape-like. go figure.
-                           my $ndots = $cdom =~ y/.//;
-                           next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
-                        } else {
-                           $cdom = $uhost;
-                        }
-                        # store it
-                        $arg{cookie_jar}{version} = 1;
-                        $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
-                        redo if /\G\s*,/gc;
-                     }
-                  }
-                  if ($redirect && exists $hdr{location}) {
-                     # we ignore any errors, as it is very common to receive
-                     # Content-Length != 0 but no actual body
-                     # we also access %hdr, as $_[1] might be an erro
-                     http_request (
-                        $method  => $hdr{location},
-                        %arg,
-                        recurse  => $recurse - 1,
-                        Redirect => [$_[0], \%hdr],
-                        $cb);
-                  } else {
-                     $cb->($_[0], \%hdr);
-                  }
-               };
-               my $len = $hdr{"content-length"};
-               if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
-                  $finish->(undef, 598 => "Request cancelled by on_header");
-               } elsif (
-                  $hdr{Status} =~ /^(?:1..|204|205|304)$/
-                  or $method eq "HEAD"
-                  or (defined $len && !$len)
-               ) {
-                  # no body
-                  $finish->("", undef, undef, 1);
-               } else {
-                  # body handling, many different code paths
-                  # - no body expected
-                  # - want_body_handle
-                  # - te chunked
-                  # - 2x length known (with or without on_body)
-                  # - 2x length not known (with or without on_body)
-                  if (!$redirect && $arg{want_body_handle}) {
-                     $_[0]->on_eof   (undef);
-                     $_[0]->on_error (undef);
-                     $_[0]->on_read  (undef);
-                     $finish->(delete $state{handle});
-                  } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
-                     my $cl = 0;
-                     my $body = undef;
-                     my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
-                     $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
-                     my $read_chunk; $read_chunk = sub {
-                        $_[1] =~ /^([0-9a-fA-F]+)/
-                           or $finish->(undef, 599 => "Garbled chunked transfer encoding");
-                        my $len = hex $1;
-                        if ($len) {
-                           $cl += $len;
-                           $_[0]->push_read (chunk => $len, sub {
-                              $on_body->($_[1], \%hdr)
-                                 or return $finish->(undef, 598 => "Request cancelled by on_body");
-                              $_[0]->push_read (line => sub {
-                                 length $_[1]
-                                    and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
-                                 $_[0]->push_read (line => $read_chunk);
-                              });
-                           });
-                        } else {
-                           $hdr{"content-length"} ||= $cl;
-                           $_[0]->push_read (line => $qr_nlnl, sub {
-                              if (length $_[1]) {
-                                 for ("$_[1]") {
-                                    y/\015//d; # weed out any \015, as they show up in the weirdest of places.
-                                    my $hdr = parse_hdr
-                                       or return $finish->(undef, 599 => "Garbled response trailers");
-                                    %hdr = (%hdr, %$hdr);
-                                 }
-                              }
-                              $finish->($body, undef, undef, 1);
-                           });
-                        }
-                     };
-                     $_[0]->push_read (line => $read_chunk);
-                  } elsif ($arg{on_body}) {
-                     $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
-                     if ($len) {
-                        $_[0]->on_read (sub {
-                           $len -= length $_[0]{rbuf};
-                           $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
-                              or return $finish->(undef, 598 => "Request cancelled by on_body");
-                           $len > 0
-                              or $finish->("", undef, undef, 1);
-                        });
-                     } else {
-                        $_[0]->on_eof (sub {
-                           $finish->("");
-                        });
-                        $_[0]->on_read (sub {
-                           $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
-                              or $finish->(undef, 598 => "Request cancelled by on_body");
-                        });
-                     }
-                  } else {
-                     $_[0]->on_eof (undef);
-                     if ($len) {
-                        $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
-                        $_[0]->on_read (sub {
-                           $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
-                              if $len <= length $_[0]{rbuf};
-                        });
-                     } else {
-                        $_[0]->on_error (sub {
-                           ($! == Errno::EPIPE || !$!)
-                              ? $finish->(delete $_[0]{rbuf})
-                              : $finish->(undef, 599 => $_[2]);
-                        });
-                        $_[0]->on_read (sub { });
-                     }
-                  }
-               }
-            };
-            $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
-         };
          # now handle proxy-CONNECT method
          if ($proxy && $uscheme eq "https") {
             # oh dear, we have to wrap it into a connect request
             # maybe re-use $uauthority with patched port?
-            $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
+            $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012\015\012");
             $state{handle}->push_read (line => $qr_nlnl, sub {
                $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
                   or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
                if ($2 == 200) {
                   $rpath = $upath;
-                  &$handle_actual_request;
+                  $handle_actual_request->();
                } else {
                   %state = ();
                   $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
                }
             });
          } else {
-            &$handle_actual_request;
+            $handle_actual_request->();
          }
       };
       my $tcp_connect = $arg{tcp_connect}
                         || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
       $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
    };
    defined wantarray && AnyEvent::Util::guard { %state = () }
 }
 string of the form C<http://host:port> (optionally C<https:...>), croaks
 otherwise.
 To clear an already-set proxy, use C<undef>.
+=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
+Remove all cookies from the cookie jar that have been expired. If
+C<$session_end> is given and true, then additionally remove all session
+cookies.
+You should call this function (with a true C<$session_end>) before you
+save cookies to disk, and you should call this function after loading them
+again. If you have a long-running program you can additonally call this
+function from time to time.
+A cookie jar is initially an empty hash-reference that is managed by this
+module. It's format is subject to change, but currently it is like this:
+The key C<version> has to contain C<1>, otherwise the hash gets
+emptied. All other keys are hostnames or IP addresses pointing to
+hash-references. The key for these inner hash references is the
+server path for which this cookie is meant, and the values are again
+hash-references. The keys of those hash-references is the cookie name, and
+the value, you guessed it, is another hash-reference, this time with the
+key-value pairs from the cookie, except for C<expires> and C<max-age>,
+which have been replaced by a C<_expires> key that contains the cookie
+expiry timestamp.
+Here is an example of a cookie jar with a single cookie, so you have a
+chance of understanding the above paragraph:
+   {
+      version    => 1,
+      "10.0.0.1" => {
+         "/" => {
+            "mythweb_id" => {
+              _expires => 1293917923,
+              value    => "ooRung9dThee3ooyXooM1Ohm",
+            },
+         },
+      },
+   }
 =item $date = AnyEvent::HTTP::format_date $timestamp
 Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
 Date (RFC 2616).
 =item $timestamp = AnyEvent::HTTP::parse_date $date
-Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
+Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) or a
+bunch of minor variations of those, and returns the corresponding POSIX
 timestamp, or C<undef> if the date cannot be parsed.
 =item $AnyEvent::HTTP::MAX_RECURSE
 The default value for the C<recurse> request parameter (default: C<10>).
 sub parse_date($) {
    my ($date) = @_;
    my ($d, $m, $y, $H, $M, $S);
-   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$/) {
+   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$/) {
-      # RFC 822/1123, required by RFC 2616
+      # RFC 822/1123, required by RFC 2616 (with " ")
+      # cookie dates (with "-")
       ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
-   } 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$/) {
+   } elsif ($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]?) GMT$/) {
       # RFC 850
       ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
-   } elsif ($date =~ /^[A-Z][a-z][a-z] ([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][0-9][0-9])$/) {
+   } elsif ($date =~ /^[A-Z][a-z][a-z]+ ([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][0-9][0-9])$/) {
       # ISO C's asctime
       ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
    }
    # other formats fail in the loop below

Diff Legend

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

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.69 by root, Fri Dec 31 19:32:47 2010 UTC vs. Revision 1.87 by root, Sun Jan 2 08:51:53 2011 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.69 by root, Fri Dec 31 19:32:47 2010 UTC vs.
Revision 1.87 by root, Sun Jan 2 08:51:53 2011 UTC