[Summary view] [Print] [Text view]

   1  package CGI::Cookie;
   2  
   3  # See the bottom of this file for the POD documentation.  Search for the
   4  # string '=head'.
   5  
   6  # You can run this file through either pod2man or pod2html to produce pretty
   7  # documentation in manual or html file format (these utilities are part of the
   8  # Perl 5 distribution).
   9  
  10  # Copyright 1995-1999, Lincoln D. Stein.  All rights reserved.
  11  # It may be used and modified freely, but I do request that this copyright
  12  # notice remain attached to the file.  You may modify this module as you 
  13  # wish, but if you redistribute a modified version, please attach a note
  14  # listing the modifications you have made.
  15  
  16  $CGI::Cookie::VERSION='1.28';
  17  
  18  use CGI::Util qw(rearrange unescape escape);
  19  use CGI;
  20  use overload '""' => \&as_string,
  21      'cmp' => \&compare,
  22      'fallback'=>1;
  23  
  24  # Turn on special checking for Doug MacEachern's modperl
  25  my $MOD_PERL = 0;
  26  if (exists $ENV{MOD_PERL}) {
  27    if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
  28        $MOD_PERL = 2;
  29        require Apache2::RequestUtil;
  30        require APR::Table;
  31    } else {
  32      $MOD_PERL = 1;
  33      require Apache;
  34    }
  35  }
  36  
  37  # fetch a list of cookies from the environment and
  38  # return as a hash.  the cookies are parsed as normal
  39  # escaped URL data.
  40  sub fetch {
  41      my $class = shift;
  42      my $raw_cookie = get_raw_cookie(@_) or return;
  43      return $class->parse($raw_cookie);
  44  }
  45  
  46  # Fetch a list of cookies from the environment or the incoming headers and
  47  # return as a hash. The cookie values are not unescaped or altered in any way.
  48   sub raw_fetch {
  49     my $class = shift;
  50     my $raw_cookie = get_raw_cookie(@_) or return;
  51     my %results;
  52     my($key,$value);
  53     
  54     my(@pairs) = split("[;,] ?",$raw_cookie);
  55     foreach (@pairs) {
  56       s/\s*(.*?)\s*/$1/;
  57       if (/^([^=]+)=(.*)/) {
  58         $key = $1;
  59         $value = $2;
  60       }
  61       else {
  62         $key = $_;
  63         $value = '';
  64       }
  65       $results{$key} = $value;
  66     }
  67     return \%results unless wantarray;
  68     return %results;
  69  }
  70  
  71  sub get_raw_cookie {
  72    my $r = shift;
  73    $r ||= eval { $MOD_PERL == 2                    ? 
  74                    Apache2::RequestUtil->request() :
  75                    Apache->request } if $MOD_PERL;
  76    if ($r) {
  77      $raw_cookie = $r->headers_in->{'Cookie'};
  78    } else {
  79      if ($MOD_PERL && !exists $ENV{REQUEST_METHOD}) {
  80        die "Run $r->subprocess_env; before calling fetch()";
  81      }
  82      $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
  83    }
  84  }
  85  
  86  
  87  sub parse {
  88    my ($self,$raw_cookie) = @_;
  89    my %results;
  90  
  91    my(@pairs) = split("; ?",$raw_cookie);
  92    foreach (@pairs) {
  93      s/\s*(.*?)\s*/$1/;
  94      my($key,$value) = split("=",$_,2);
  95  
  96      # Some foreign cookies are not in name=value format, so ignore
  97      # them.
  98      next if !defined($value);
  99      my @values = ();
 100      if ($value ne '') {
 101        @values = map unescape($_),split(/[&;]/,$value.'&dmy');
 102        pop @values;
 103      }
 104      $key = unescape($key);
 105      # A bug in Netscape can cause several cookies with same name to
 106      # appear.  The FIRST one in HTTP_COOKIE is the most recent version.
 107      $results{$key} ||= $self->new(-name=>$key,-value=>\@values);
 108    }
 109    return \%results unless wantarray;
 110    return %results;
 111  }
 112  
 113  sub new {
 114    my $class = shift;
 115    $class = ref($class) if ref($class);
 116    # Ignore mod_perl request object--compatability with Apache::Cookie.
 117    shift if ref $_[0]
 118          && eval { $_[0]->isa('Apache::Request::Req') || $_[0]->isa('Apache') };
 119    my($name,$value,$path,$domain,$secure,$expires,$httponly) =
 120      rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@_);
 121    
 122    # Pull out our parameters.
 123    my @values;
 124    if (ref($value)) {
 125      if (ref($value) eq 'ARRAY') {
 126        @values = @$value;
 127      } elsif (ref($value) eq 'HASH') {
 128        @values = %$value;
 129      }
 130    } else {
 131      @values = ($value);
 132    }
 133    
 134    bless my $self = {
 135              'name'=>$name,
 136              'value'=>[@values],
 137             },$class;
 138  
 139    # IE requires the path and domain to be present for some reason.
 140    $path   ||= "/";
 141    # however, this breaks networks which use host tables without fully qualified
 142    # names, so we comment it out.
 143    #    $domain = CGI::virtual_host()    unless defined $domain;
 144  
 145    $self->path($path)     if defined $path;
 146    $self->domain($domain) if defined $domain;
 147    $self->secure($secure) if defined $secure;
 148    $self->expires($expires) if defined $expires;
 149    $self->httponly($httponly) if defined $httponly;
 150  #  $self->max_age($expires) if defined $expires;
 151    return $self;
 152  }
 153  
 154  sub as_string {
 155      my $self = shift;
 156      return "" unless $self->name;
 157  
 158      my(@constant_values,$domain,$path,$expires,$max_age,$secure,$httponly);
 159  
 160      push(@constant_values,"domain=$domain")   if $domain = $self->domain;
 161      push(@constant_values,"path=$path")       if $path = $self->path;
 162      push(@constant_values,"expires=$expires") if $expires = $self->expires;
 163      push(@constant_values,"max-age=$max_age") if $max_age = $self->max_age;
 164      push(@constant_values,"secure") if $secure = $self->secure;
 165      push(@constant_values,"HttpOnly") if $httponly = $self->httponly;
 166  
 167      my($key) = escape($self->name);
 168      my($cookie) = join("=",(defined $key ? $key : ''),join("&",map escape(defined $_ ? $_ : ''),$self->value));
 169      return join("; ",$cookie,@constant_values);
 170  }
 171  
 172  sub compare {
 173      my $self = shift;
 174      my $value = shift;
 175      return "$self" cmp $value;
 176  }
 177  
 178  sub bake {
 179    my ($self, $r) = @_;
 180  
 181    $r ||= eval {
 182        $MOD_PERL == 2
 183            ? Apache2::RequestUtil->request()
 184            : Apache->request
 185    } if $MOD_PERL;
 186    if ($r) {
 187        $r->headers_out->add('Set-Cookie' => $self->as_string);
 188    } else {
 189        print CGI::header(-cookie => $self);
 190    }
 191  
 192  }
 193  
 194  # accessors
 195  sub name {
 196      my $self = shift;
 197      my $name = shift;
 198      $self->{'name'} = $name if defined $name;
 199      return $self->{'name'};
 200  }
 201  
 202  sub value {
 203      my $self = shift;
 204      my $value = shift;
 205        if (defined $value) {
 206                my @values;
 207          if (ref($value)) {
 208              if (ref($value) eq 'ARRAY') {
 209                  @values = @$value;
 210              } elsif (ref($value) eq 'HASH') {
 211                  @values = %$value;
 212              }
 213          } else {
 214              @values = ($value);
 215          }
 216        $self->{'value'} = [@values];
 217        }
 218      return wantarray ? @{$self->{'value'}} : $self->{'value'}->[0]
 219  }
 220  
 221  sub domain {
 222      my $self = shift;
 223      my $domain = shift;
 224      $self->{'domain'} = lc $domain if defined $domain;
 225      return $self->{'domain'};
 226  }
 227  
 228  sub secure {
 229      my $self = shift;
 230      my $secure = shift;
 231      $self->{'secure'} = $secure if defined $secure;
 232      return $self->{'secure'};
 233  }
 234  
 235  sub expires {
 236      my $self = shift;
 237      my $expires = shift;
 238      $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires;
 239      return $self->{'expires'};
 240  }
 241  
 242  sub max_age {
 243    my $self = shift;
 244    my $expires = shift;
 245    $self->{'max-age'} = CGI::Util::expire_calc($expires)-time() if defined $expires;
 246    return $self->{'max-age'};
 247  }
 248  
 249  sub path {
 250      my $self = shift;
 251      my $path = shift;
 252      $self->{'path'} = $path if defined $path;
 253      return $self->{'path'};
 254  }
 255  
 256  
 257  sub httponly { # HttpOnly
 258      my $self     = shift;
 259      my $httponly = shift;
 260      $self->{'httponly'} = $httponly if defined $httponly;
 261      return $self->{'httponly'};
 262  }
 263  
 264  1;
 265  
 266  =head1 NAME
 267  
 268  CGI::Cookie - Interface to Netscape Cookies
 269  
 270  =head1 SYNOPSIS
 271  
 272      use CGI qw/:standard/;
 273      use CGI::Cookie;
 274  
 275      # Create new cookies and send them
 276      $cookie1 = new CGI::Cookie(-name=>'ID',-value=>123456);
 277      $cookie2 = new CGI::Cookie(-name=>'preferences',
 278                                 -value=>{ font => Helvetica,
 279                                           size => 12 } 
 280                                 );
 281      print header(-cookie=>[$cookie1,$cookie2]);
 282  
 283      # fetch existing cookies
 284      %cookies = fetch CGI::Cookie;
 285      $id = $cookies{'ID'}->value;
 286  
 287      # create cookies returned from an external source
 288      %cookies = parse CGI::Cookie($ENV{COOKIE});
 289  
 290  =head1 DESCRIPTION
 291  
 292  CGI::Cookie is an interface to Netscape (HTTP/1.1) cookies, an
 293  innovation that allows Web servers to store persistent information on
 294  the browser's side of the connection.  Although CGI::Cookie is
 295  intended to be used in conjunction with CGI.pm (and is in fact used by
 296  it internally), you can use this module independently.
 297  
 298  For full information on cookies see 
 299  
 300      http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt
 301  
 302  =head1 USING CGI::Cookie
 303  
 304  CGI::Cookie is object oriented.  Each cookie object has a name and a
 305  value.  The name is any scalar value.  The value is any scalar or
 306  array value (associative arrays are also allowed).  Cookies also have
 307  several optional attributes, including:
 308  
 309  =over 4
 310  
 311  =item B<1. expiration date>
 312  
 313  The expiration date tells the browser how long to hang on to the
 314  cookie.  If the cookie specifies an expiration date in the future, the
 315  browser will store the cookie information in a disk file and return it
 316  to the server every time the user reconnects (until the expiration
 317  date is reached).  If the cookie species an expiration date in the
 318  past, the browser will remove the cookie from the disk file.  If the
 319  expiration date is not specified, the cookie will persist only until
 320  the user quits the browser.
 321  
 322  =item B<2. domain>
 323  
 324  This is a partial or complete domain name for which the cookie is 
 325  valid.  The browser will return the cookie to any host that matches
 326  the partial domain name.  For example, if you specify a domain name
 327  of ".capricorn.com", then Netscape will return the cookie to
 328  Web servers running on any of the machines "www.capricorn.com", 
 329  "ftp.capricorn.com", "feckless.capricorn.com", etc.  Domain names
 330  must contain at least two periods to prevent attempts to match
 331  on top level domains like ".edu".  If no domain is specified, then
 332  the browser will only return the cookie to servers on the host the
 333  cookie originated from.
 334  
 335  =item B<3. path>
 336  
 337  If you provide a cookie path attribute, the browser will check it
 338  against your script's URL before returning the cookie.  For example,
 339  if you specify the path "/cgi-bin", then the cookie will be returned
 340  to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and
 341  "/cgi-bin/customer_service/complain.pl", but not to the script
 342  "/cgi-private/site_admin.pl".  By default, the path is set to "/", so
 343  that all scripts at your site will receive the cookie.
 344  
 345  =item B<4. secure flag>
 346  
 347  If the "secure" attribute is set, the cookie will only be sent to your
 348  script if the CGI request is occurring on a secure channel, such as SSL.
 349  
 350  =item B<4. httponly flag>
 351  
 352  If the "httponly" attribute is set, the cookie will only be accessible
 353  through HTTP Requests. This cookie will be inaccessible via JavaScript
 354  (to prevent XSS attacks).
 355  
 356  But, currently this feature only used and recognised by 
 357  MS Internet Explorer 6 Service Pack 1 and later.
 358  
 359  See this URL for more information:
 360  
 361  L<http://msdn.microsoft.com/workshop/author/dhtml/httponly_cookies.asp>
 362  
 363  =back
 364  
 365  =head2 Creating New Cookies
 366  
 367      my $c = new CGI::Cookie(-name    =>  'foo',
 368                               -value   =>  'bar',
 369                               -expires =>  '+3M',
 370                               -domain  =>  '.capricorn.com',
 371                               -path    =>  '/cgi-bin/database',
 372                               -secure  =>  1
 373                          );
 374  
 375  Create cookies from scratch with the B<new> method.  The B<-name> and
 376  B<-value> parameters are required.  The name must be a scalar value.
 377  The value can be a scalar, an array reference, or a hash reference.
 378  (At some point in the future cookies will support one of the Perl
 379  object serialization protocols for full generality).
 380  
 381  B<-expires> accepts any of the relative or absolute date formats
 382  recognized by CGI.pm, for example "+3M" for three months in the
 383  future.  See CGI.pm's documentation for details.
 384  
 385  B<-domain> points to a domain name or to a fully qualified host name.
 386  If not specified, the cookie will be returned only to the Web server
 387  that created it.
 388  
 389  B<-path> points to a partial URL on the current server.  The cookie
 390  will be returned to all URLs beginning with the specified path.  If
 391  not specified, it defaults to '/', which returns the cookie to all
 392  pages at your site.
 393  
 394  B<-secure> if set to a true value instructs the browser to return the
 395  cookie only when a cryptographic protocol is in use.
 396  
 397  B<-httponly> if set to a true value, the cookie will not be accessible
 398  via JavaScript.
 399  
 400  For compatibility with Apache::Cookie, you may optionally pass in
 401  a mod_perl request object as the first argument to C<new()>. It will
 402  simply be ignored:
 403  
 404    my $c = new CGI::Cookie($r,
 405                            -name    =>  'foo',
 406                            -value   =>  ['bar','baz']);
 407  
 408  =head2 Sending the Cookie to the Browser
 409  
 410  The simplest way to send a cookie to the browser is by calling the bake()
 411  method:
 412  
 413    $c->bake;
 414  
 415  Under mod_perl, pass in an Apache request object:
 416  
 417    $c->bake($r);
 418  
 419  If you want to set the cookie yourself, Within a CGI script you can send
 420  a cookie to the browser by creating one or more Set-Cookie: fields in the
 421  HTTP header.  Here is a typical sequence:
 422  
 423    my $c = new CGI::Cookie(-name    =>  'foo',
 424                            -value   =>  ['bar','baz'],
 425                            -expires =>  '+3M');
 426  
 427    print "Set-Cookie: $c\n";
 428    print "Content-Type: text/html\n\n";
 429  
 430  To send more than one cookie, create several Set-Cookie: fields.
 431  
 432  If you are using CGI.pm, you send cookies by providing a -cookie
 433  argument to the header() method:
 434  
 435    print header(-cookie=>$c);
 436  
 437  Mod_perl users can set cookies using the request object's header_out()
 438  method:
 439  
 440    $r->headers_out->set('Set-Cookie' => $c);
 441  
 442  Internally, Cookie overloads the "" operator to call its as_string()
 443  method when incorporated into the HTTP header.  as_string() turns the
 444  Cookie's internal representation into an RFC-compliant text
 445  representation.  You may call as_string() yourself if you prefer:
 446  
 447    print "Set-Cookie: ",$c->as_string,"\n";
 448  
 449  =head2 Recovering Previous Cookies
 450  
 451      %cookies = fetch CGI::Cookie;
 452  
 453  B<fetch> returns an associative array consisting of all cookies
 454  returned by the browser.  The keys of the array are the cookie names.  You
 455  can iterate through the cookies this way:
 456  
 457      %cookies = fetch CGI::Cookie;
 458      foreach (keys %cookies) {
 459         do_something($cookies{$_});
 460          }
 461  
 462  In a scalar context, fetch() returns a hash reference, which may be more
 463  efficient if you are manipulating multiple cookies.
 464  
 465  CGI.pm uses the URL escaping methods to save and restore reserved characters
 466  in its cookies.  If you are trying to retrieve a cookie set by a foreign server,
 467  this escaping method may trip you up.  Use raw_fetch() instead, which has the
 468  same semantics as fetch(), but performs no unescaping.
 469  
 470  You may also retrieve cookies that were stored in some external
 471  form using the parse() class method:
 472  
 473         $COOKIES = `cat /usr/tmp/Cookie_stash`;
 474         %cookies = parse CGI::Cookie($COOKIES);
 475  
 476  If you are in a mod_perl environment, you can save some overhead by
 477  passing the request object to fetch() like this:
 478  
 479     CGI::Cookie->fetch($r);
 480  
 481  =head2 Manipulating Cookies
 482  
 483  Cookie objects have a series of accessor methods to get and set cookie
 484  attributes.  Each accessor has a similar syntax.  Called without
 485  arguments, the accessor returns the current value of the attribute.
 486  Called with an argument, the accessor changes the attribute and
 487  returns its new value.
 488  
 489  =over 4
 490  
 491  =item B<name()>
 492  
 493  Get or set the cookie's name.  Example:
 494  
 495      $name = $c->name;
 496      $new_name = $c->name('fred');
 497  
 498  =item B<value()>
 499  
 500  Get or set the cookie's value.  Example:
 501  
 502      $value = $c->value;
 503      @new_value = $c->value(['a','b','c','d']);
 504  
 505  B<value()> is context sensitive.  In a list context it will return
 506  the current value of the cookie as an array.  In a scalar context it
 507  will return the B<first> value of a multivalued cookie.
 508  
 509  =item B<domain()>
 510  
 511  Get or set the cookie's domain.
 512  
 513  =item B<path()>
 514  
 515  Get or set the cookie's path.
 516  
 517  =item B<expires()>
 518  
 519  Get or set the cookie's expiration time.
 520  
 521  =back
 522  
 523  
 524  =head1 AUTHOR INFORMATION
 525  
 526  Copyright 1997-1998, Lincoln D. Stein.  All rights reserved.  
 527  
 528  This library is free software; you can redistribute it and/or modify
 529  it under the same terms as Perl itself.
 530  
 531  Address bug reports and comments to: lstein@cshl.org
 532  
 533  =head1 BUGS
 534  
 535  This section intentionally left blank.
 536  
 537  =head1 SEE ALSO
 538  
 539  L<CGI::Carp>, L<CGI>
 540  
 541  =cut