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 6737832..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,
@@ -57,61 +57,67 @@ sub raw_fetch {
     return %results;
 }
 
-sub parse {
-    my ($self,$raw_cookie) = @_;
-    my %results;
 
-    my(@pairs) = split("; ?",$raw_cookie);
-    foreach (@pairs) {
-      s/\s*(.*?)\s*/$1/;
-      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 {
@@ -123,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));
@@ -147,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]
 }
 
@@ -273,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
                            );