Upgrade to the CGI.pm 2.93.

[p5sagit/p5-mst-13.2.git] / lib / CGI / Cookie.pm

diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm
index 7c7434c..7060fb4 100644 (file)
--- a/lib/CGI/Cookie.pm
+++ b/lib/CGI/Cookie.pm
@@ -13,48 +13,73 @@ package CGI::Cookie;
 # wish, but if you redistribute a modified version, please attach a note
 # listing the modifications you have made.
 
-$CGI::Cookie::VERSION='1.21';
+$CGI::Cookie::VERSION='1.24';
 
 use CGI::Util qw(rearrange unescape escape);
 use overload '""' => \&as_string,
     'cmp' => \&compare,
     'fallback'=>1;
 
+# Turn on special checking for Doug MacEachern's modperl
+my $MOD_PERL = 0;
+if (exists $ENV{MOD_PERL}) {
+  eval "require mod_perl";
+  if (defined $mod_perl::VERSION) {
+    if ($mod_perl::VERSION >= 1.99) {
+      $MOD_PERL = 2;
+      require Apache::RequestUtil;
+    } else {
+      $MOD_PERL = 1;
+      require Apache;
+    }
+  }
+}
+
 # fetch a list of cookies from the environment and
 # return as a hash.  the cookies are parsed as normal
 # escaped URL data.
 sub fetch {
     my $class = shift;
-    my $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
-    return () unless $raw_cookie;
+    my $raw_cookie = get_raw_cookie(@_) or return;
     return $class->parse($raw_cookie);
 }
 
-# fetch a list of cookies from the environment and
-# return as a hash.  the cookie values are not unescaped
-# or altered in any way.
-sub raw_fetch {
-    my $class = shift;
-    my $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
-    return () unless $raw_cookie;
-    my %results;
-    my($key,$value);
-
-    my(@pairs) = split("; ?",$raw_cookie);
-    foreach (@pairs) {
-      s/\s*(.*?)\s*/$1/;
-      if (/^([^=]+)=(.*)/) {
-       $key = $1;
-       $value = $2;
-      }
-      else {
-       $key = $_;
-       $value = '';
-      }
-      $results{$key} = $value;
+# Fetch a list of cookies from the environment or the incoming headers and
+# return as a hash. The cookie values are not unescaped or altered in any way.
+ sub raw_fetch {
+   my $class = shift;
+   my $raw_cookie = get_raw_cookie(@_) or return;
+   my %results;
+   my($key,$value);
+   
+   my(@pairs) = split("; ?",$raw_cookie);
+   foreach (@pairs) {
+     s/\s*(.*?)\s*/$1/;
+     if (/^([^=]+)=(.*)/) {
+       $key = $1;
+       $value = $2;
+     }
+     else {
+       $key = $_;
+       $value = '';
+     }
+     $results{$key} = $value;
+   }
+   return \%results unless wantarray;
+   return %results;
+}
+
+sub get_raw_cookie {
+  my $r = shift;
+  $r ||= eval { Apache->request() } if $MOD_PERL;
+  if ($r) {
+    $raw_cookie = $r->headers_in->{'Cookie'};
+  } else {
+    if ($MOD_PERL && !exists $ENV{REQUEST_METHOD}) {
+      die "Run $r->subprocess_env; before calling fetch()";
     }
-    return \%results unless wantarray;
-    return %results;
+    $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
+  }
 }
 
 
@@ -340,8 +365,6 @@ sequence:
   print "Content-Type: text/html\n\n";
 
 To send more than one cookie, create several Set-Cookie: fields.
-Alternatively, you may concatenate the cookies together with "; " and
-send them in one field.
 
 If you are using CGI.pm, you send cookies by providing a -cookie
 argument to the header() method:
@@ -351,7 +374,7 @@ argument to the header() method:
 Mod_perl users can set cookies using the request object's header_out()
 method:
 
-  $r->header_out('Set-Cookie',$c);
+  $r->headers_out->set('Set-Cookie' => $c);
 
 Internally, Cookie overloads the "" operator to call its as_string()
 method when incorporated into the HTTP header.  as_string() turns the
@@ -387,6 +410,11 @@ form using the parse() class method:
        $COOKIES = `cat /usr/tmp/Cookie_stash`;
        %cookies = parse CGI::Cookie($COOKIES);
 
+If you are in a mod_perl environment, you can save some overhead by
+passing the request object to fetch() like this:
+
+   CGI::Cookie->fetch($r);
+
 =head2 Manipulating Cookies
 
 Cookie objects have a series of accessor methods to get and set cookie