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

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.79 by root, Sat Jan 1 20:01:07 2011 UTC vs.
Revision 1.80 by root, Sat Jan 1 21:51:22 2011 UTC

 =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 session-only cookies might survive longer than expected.
+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 meant to be complete. If
 you want complete cookie management you have to do that on your
-own. C<cookie_jar> is meant as a quick fix to get some cookie-using sites
+own. C<cookie_jar> is meant as a quick fix to get most cookie-using sites
 working. Cookies are a privacy disaster, do not use them unless required
 to.
 When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
 headers will be set and handled by this module, otherwise they will be
    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;
          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}) {
+            if (exists $kv->{_expires} and AE::now > $kv->{_expires}) {
-               if (AE::now > parse_date ($kv->{expires})) {
-                  delete $cookies->{$cookie};
+               delete $cookies->{$cookie};
-                  next;
+               next;
-               }
             }
             my $value = $kv->{value};
             if ($value =~ /[=;,[:space:]]/) {
    \@cookies
 }
 # parse set_cookie header into jar
-sub cookie_jar_set_cookie($$$) {
+sub cookie_jar_set_cookie($$$$) {
-   my ($jar, $set_cookie, $uhost) = @_;
+   my ($jar, $set_cookie, $uhost, $date) = @_;
+   my $anow = int AE::now;
+   my $snow; # server-now
    for ($set_cookie) {
       # parse NAME=VALUE
       my @kv;
       last unless @kv;
       my $name = shift @kv;
       my %kv = (value => shift @kv, @kv);
-      $kv{expires} ||= format_date (AE::now + $kv{"max-age"})
-         if exists $kv{"max-age"};
+      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}) {
                      $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;
+                     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
 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).

Diff Legend

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

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.79 by root, Sat Jan 1 20:01:07 2011 UTC vs. Revision 1.80 by root, Sat Jan 1 21:51:22 2011 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.79 by root, Sat Jan 1 20:01:07 2011 UTC vs.
Revision 1.80 by root, Sat Jan 1 21:51:22 2011 UTC