consistent commands for perl5db.pl etc.

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

diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm
index 9e5a14b..1e1cfde 100644 (file)
--- a/lib/CGI/Cookie.pm
+++ b/lib/CGI/Cookie.pm
@@ -13,7 +13,7 @@ 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.16';
+$CGI::Cookie::VERSION='1.20';
 
 use CGI::Util qw(rearrange unescape escape);
 use overload '""' => \&as_string,
@@ -40,76 +40,84 @@ sub raw_fetch {
     my %results;
     my($key,$value);
 
-    my(@pairs) = split("; ",$raw_cookie);
+    my(@pairs) = split("; ?",$raw_cookie);
     foreach (@pairs) {
-       if (/^([^=]+)=(.*)/) {
-           $key = $1;
-           $value = $2;
-       }
-       else {
-           $key = $_;
-           $value = '';
-       }
-       $results{$key} = $value;
+      s/\s*(.*?)\s*/$1/;
+      if (/^([^=]+)=(.*)/) {
+       $key = $1;
+       $value = $2;
+      }
+      else {
+       $key = $_;
+       $value = '';
+      }
+      $results{$key} = $value;
     }
     return \%results unless wantarray;
     return %results;
 }
 
-sub parse {
-    my ($self,$raw_cookie) = @_;
-    my %results;
 
-    my(@pairs) = split("; ",$raw_cookie);
-    foreach (@pairs) {
-       my($key,$value) = split("=");
-       my(@values) = map unescape($_),split('&',$value);
-       $key = unescape($key);
-       # Some foreign cookies are not in name=value format, so ignore
-       # them.
-       next if !defined($value);
-       # A bug in Netscape can cause several cookies with same name to
-       # appear.  The FIRST one in HTTP_COOKIE is the most recent version.
-       $results{$key} ||= $self->new(-name=>$key,-value=>\@values);
+sub parse {
+  my ($self,$raw_cookie) = @_;
+  my %results;
+
+  my(@pairs) = split("; ?",$raw_cookie);
+  foreach (@pairs) {
+    s/\s*(.*?)\s*/$1/;
+    my($key,$value) = split("=",$_,2);
+
+    # Some foreign cookies are not in name=value format, so ignore
+    # them.
+    next if !defined($value);
+    my @values = ();
+    if ($value ne '') {
+      @values = map unescape($_),split(/[&;]/,$value.'&dmy');
+      pop @values;
     }
-    return \%results unless wantarray;
-    return %results;
+    $key = unescape($key);
+    # A bug in Netscape can cause several cookies with same name to
+    # appear.  The FIRST one in HTTP_COOKIE is the most recent version.
+    $results{$key} ||= $self->new(-name=>$key,-value=>\@values);
+  }
+  return \%results unless wantarray;
+  return %results;
 }
 
 sub new {
-    my $class = shift;
-    $class = ref($class) if ref($class);
-    my($name,$value,$path,$domain,$secure,$expires) =
-      rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_);
-
-    # Pull out our parameters.
-    my @values;
-    if (ref($value)) {
-       if (ref($value) eq 'ARRAY') {
-           @values = @$value;
-       } elsif (ref($value) eq 'HASH') {
-           @values = %$value;
-       }
-    } else {
-       @values = ($value);
+  my $class = shift;
+  $class = ref($class) if ref($class);
+  my($name,$value,$path,$domain,$secure,$expires) =
+    rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_);
+  
+  # Pull out our parameters.
+  my @values;
+  if (ref($value)) {
+    if (ref($value) eq 'ARRAY') {
+      @values = @$value;
+    } elsif (ref($value) eq 'HASH') {
+      @values = %$value;
     }
-
-    bless my $self = {
-       'name'=>$name,
-       'value'=>[@values],
-       },$class;
-
-    # IE requires the path and domain to be present for some reason.
-    $path   ||= '/';
-# however, this breaks networks which use host tables without fully qualified
-# names, so we comment it out.
-#    $domain = CGI::virtual_host()    unless defined $domain;
-
-    $self->path($path)     if defined $path;
-    $self->domain($domain) if defined $domain;
-    $self->secure($secure) if defined $secure;
-    $self->expires($expires) if defined $expires;
-    return $self;
+  } else {
+    @values = ($value);
+  }
+  
+  bless my $self = {
+                   'name'=>$name,
+                   'value'=>[@values],
+                  },$class;
+
+  # IE requires the path and domain to be present for some reason.
+  $path   ||= "/";
+  # however, this breaks networks which use host tables without fully qualified
+  # names, so we comment it out.
+  #    $domain = CGI::virtual_host()    unless defined $domain;
+
+  $self->path($path)     if defined $path;
+  $self->domain($domain) if defined $domain;
+  $self->secure($secure) if defined $secure;
+  $self->expires($expires) if defined $expires;
+  return $self;
 }
 
 sub as_string {
@@ -121,7 +129,7 @@ sub as_string {
     push(@constant_values,"domain=$domain") if $domain = $self->domain;
     push(@constant_values,"path=$path") if $path = $self->path;
     push(@constant_values,"expires=$expires") if $expires = $self->expires;
-    push(@constant_values,'secure') if $secure = $self->secure;
+    push(@constant_values,"secure") if $secure = $self->secure;
 
     my($key) = escape($self->name);
     my($cookie) = join("=",$key,join("&",map escape($_),$self->value));
@@ -145,7 +153,19 @@ sub name {
 sub value {
     my $self = shift;
     my $value = shift;
-    $self->{'value'} = $value if defined $value;
+      if (defined $value) {
+              my @values;
+        if (ref($value)) {
+            if (ref($value) eq 'ARRAY') {
+                @values = @$value;
+            } elsif (ref($value) eq 'HASH') {
+                @values = %$value;
+            }
+        } else {
+            @values = ($value);
+        }
+      $self->{'value'} = [@values];
+      }
     return wantarray ? @{$self->{'value'}} : $self->{'value'}->[0]
 }
 
@@ -271,7 +291,7 @@ script if the CGI request is occurring on a secure channel, such as SSL.
                              -value   =>  'bar',
                              -expires =>  '+3M',
                              -domain  =>  '.capricorn.com',
-                             -path    =>  '/cgi-bin/database'
+                             -path    =>  '/cgi-bin/database',
                              -secure  =>  1
                            );
 
@@ -382,7 +402,7 @@ Get or set the cookie's value.  Example:
        $value = $c->value;
        @new_value = $c->value(['a','b','c','d']);
 
-B<value()> is context sensitive.  In an array context it will return
+B<value()> is context sensitive.  In a list context it will return
 the current value of the cookie as an array.  In a scalar context it
 will return the B<first> value of a multivalued cookie.