lib/CGI/Cookie.pm

   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.16';
  17
  18 use CGI::Util qw(rearrange unescape escape);
  19 use overload '""' => \&as_string,
  20     'cmp' => \&compare,
  21     'fallback'=>1;
  22
  23 # fetch a list of cookies from the environment and
  24 # return as a hash.  the cookies are parsed as normal
  25 # escaped URL data.
  26 sub fetch {
  27     my $class = shift;
  28     my $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
  29     return () unless $raw_cookie;
  30     return $class->parse($raw_cookie);
  31 }
  32
  33 # fetch a list of cookies from the environment and
  34 # return as a hash.  the cookie values are not unescaped
  35 # or altered in any way.
  36 sub raw_fetch {
  37     my $class = shift;
  38     my $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
  39     return () unless $raw_cookie;
  40     my %results;
  41     my($key,$value);
  42
  43     my(@pairs) = split("; ",$raw_cookie);
  44     foreach (@pairs) {
  45         if (/^([^=]+)=(.*)/) {
  46             $key = $1;
  47             $value = $2;
  48         }
  49         else {
  50             $key = $_;
  51             $value = '';
  52         }
  53         $results{$key} = $value;
  54     }
  55     return \%results unless wantarray;
  56     return %results;
  57 }
  58
  59 sub parse {
  60     my ($self,$raw_cookie) = @_;
  61     my %results;
  62
  63     my(@pairs) = split("; ",$raw_cookie);
  64     foreach (@pairs) {
  65         my($key,$value) = split("=");
  66         my(@values) = map unescape($_),split('&',$value);
  67         $key = unescape($key);
  68         # Some foreign cookies are not in name=value format, so ignore
  69         # them.
  70         next if !defined($value);
  71         # A bug in Netscape can cause several cookies with same name to
  72         # appear.  The FIRST one in HTTP_COOKIE is the most recent version.
  73         $results{$key} ||= $self->new(-name=>$key,-value=>\@values);
  74     }
  75     return \%results unless wantarray;
  76     return %results;
  77 }
  78
  79 sub new {
  80     my $class = shift;
  81     $class = ref($class) if ref($class);
  82     my($name,$value,$path,$domain,$secure,$expires) =
  83       rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_);
  84
  85     # Pull out our parameters.
  86     my @values;
  87     if (ref($value)) {
  88         if (ref($value) eq 'ARRAY') {
  89             @values = @$value;
  90         } elsif (ref($value) eq 'HASH') {
  91             @values = %$value;
  92         }
  93     } else {
  94         @values = ($value);
  95     }
  96
  97     bless my $self = {
  98         'name'=>$name,
  99         'value'=>[@values],
 100         },$class;
 101
 102     # IE requires the path and domain to be present for some reason.
 103     $path   ||= '/';
 104 # however, this breaks networks which use host tables without fully qualified
 105 # names, so we comment it out.
 106 #    $domain = CGI::virtual_host()    unless defined $domain;
 107
 108     $self->path($path)     if defined $path;
 109     $self->domain($domain) if defined $domain;
 110     $self->secure($secure) if defined $secure;
 111     $self->expires($expires) if defined $expires;
 112     return $self;
 113 }
 114
 115 sub as_string {
 116     my $self = shift;
 117     return "" unless $self->name;
 118
 119     my(@constant_values,$domain,$path,$expires,$secure);
 120
 121     push(@constant_values,"domain=$domain") if $domain = $self->domain;
 122     push(@constant_values,"path=$path") if $path = $self->path;
 123     push(@constant_values,"expires=$expires") if $expires = $self->expires;
 124     push(@constant_values,'secure') if $secure = $self->secure;
 125
 126     my($key) = escape($self->name);
 127     my($cookie) = join("=",$key,join("&",map escape($_),$self->value));
 128     return join("; ",$cookie,@constant_values);
 129 }
 130
 131 sub compare {
 132     my $self = shift;
 133     my $value = shift;
 134     return "$self" cmp $value;
 135 }
 136
 137 # accessors
 138 sub name {
 139     my $self = shift;
 140     my $name = shift;
 141     $self->{'name'} = $name if defined $name;
 142     return $self->{'name'};
 143 }
 144
 145 sub value {
 146     my $self = shift;
 147     my $value = shift;
 148     $self->{'value'} = $value if defined $value;
 149     return wantarray ? @{$self->{'value'}} : $self->{'value'}->[0]
 150 }
 151
 152 sub domain {
 153     my $self = shift;
 154     my $domain = shift;
 155     $self->{'domain'} = $domain if defined $domain;
 156     return $self->{'domain'};
 157 }
 158
 159 sub secure {
 160     my $self = shift;
 161     my $secure = shift;
 162     $self->{'secure'} = $secure if defined $secure;
 163     return $self->{'secure'};
 164 }
 165
 166 sub expires {
 167     my $self = shift;
 168     my $expires = shift;
 169     $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires;
 170     return $self->{'expires'};
 171 }
 172
 173 sub path {
 174     my $self = shift;
 175     my $path = shift;
 176     $self->{'path'} = $path if defined $path;
 177     return $self->{'path'};
 178 }
 179
 180 1;
 181
 182 =head1 NAME
 183
 184 CGI::Cookie - Interface to Netscape Cookies
 185
 186 =head1 SYNOPSIS
 187
 188     use CGI qw/:standard/;
 189     use CGI::Cookie;
 190
 191     # Create new cookies and send them
 192     $cookie1 = new CGI::Cookie(-name=>'ID',-value=>123456);
 193     $cookie2 = new CGI::Cookie(-name=>'preferences',
 194                                -value=>{ font => Helvetica,
 195                                          size => 12 }
 196                                );
 197     print header(-cookie=>[$cookie1,$cookie2]);
 198
 199     # fetch existing cookies
 200     %cookies = fetch CGI::Cookie;
 201     $id = $cookies{'ID'}->value;
 202
 203     # create cookies returned from an external source
 204     %cookies = parse CGI::Cookie($ENV{COOKIE});
 205
 206 =head1 DESCRIPTION
 207
 208 CGI::Cookie is an interface to Netscape (HTTP/1.1) cookies, an
 209 innovation that allows Web servers to store persistent information on
 210 the browser's side of the connection.  Although CGI::Cookie is
 211 intended to be used in conjunction with CGI.pm (and is in fact used by
 212 it internally), you can use this module independently.
 213
 214 For full information on cookies see
 215
 216         http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt
 217
 218 =head1 USING CGI::Cookie
 219
 220 CGI::Cookie is object oriented.  Each cookie object has a name and a
 221 value.  The name is any scalar value.  The value is any scalar or
 222 array value (associative arrays are also allowed).  Cookies also have
 223 several optional attributes, including:
 224
 225 =over 4
 226
 227 =item B<1. expiration date>
 228
 229 The expiration date tells the browser how long to hang on to the
 230 cookie.  If the cookie specifies an expiration date in the future, the
 231 browser will store the cookie information in a disk file and return it
 232 to the server every time the user reconnects (until the expiration
 233 date is reached).  If the cookie species an expiration date in the
 234 past, the browser will remove the cookie from the disk file.  If the
 235 expiration date is not specified, the cookie will persist only until
 236 the user quits the browser.
 237
 238 =item B<2. domain>
 239
 240 This is a partial or complete domain name for which the cookie is
 241 valid.  The browser will return the cookie to any host that matches
 242 the partial domain name.  For example, if you specify a domain name
 243 of ".capricorn.com", then Netscape will return the cookie to
 244 Web servers running on any of the machines "www.capricorn.com",
 245 "ftp.capricorn.com", "feckless.capricorn.com", etc.  Domain names
 246 must contain at least two periods to prevent attempts to match
 247 on top level domains like ".edu".  If no domain is specified, then
 248 the browser will only return the cookie to servers on the host the
 249 cookie originated from.
 250
 251 =item B<3. path>
 252
 253 If you provide a cookie path attribute, the browser will check it
 254 against your script's URL before returning the cookie.  For example,
 255 if you specify the path "/cgi-bin", then the cookie will be returned
 256 to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and
 257 "/cgi-bin/customer_service/complain.pl", but not to the script
 258 "/cgi-private/site_admin.pl".  By default, the path is set to "/", so
 259 that all scripts at your site will receive the cookie.
 260
 261 =item B<4. secure flag>
 262
 263 If the "secure" attribute is set, the cookie will only be sent to your
 264 script if the CGI request is occurring on a secure channel, such as SSL.
 265
 266 =back
 267
 268 =head2 Creating New Cookies
 269
 270         $c = new CGI::Cookie(-name    =>  'foo',
 271                              -value   =>  'bar',
 272                              -expires =>  '+3M',
 273                              -domain  =>  '.capricorn.com',
 274                              -path    =>  '/cgi-bin/database'
 275                              -secure  =>  1
 276                             );
 277
 278 Create cookies from scratch with the B<new> method.  The B<-name> and
 279 B<-value> parameters are required.  The name must be a scalar value.
 280 The value can be a scalar, an array reference, or a hash reference.
 281 (At some point in the future cookies will support one of the Perl
 282 object serialization protocols for full generality).
 283
 284 B<-expires> accepts any of the relative or absolute date formats
 285 recognized by CGI.pm, for example "+3M" for three months in the
 286 future.  See CGI.pm's documentation for details.
 287
 288 B<-domain> points to a domain name or to a fully qualified host name.
 289 If not specified, the cookie will be returned only to the Web server
 290 that created it.
 291
 292 B<-path> points to a partial URL on the current server.  The cookie
 293 will be returned to all URLs beginning with the specified path.  If
 294 not specified, it defaults to '/', which returns the cookie to all
 295 pages at your site.
 296
 297 B<-secure> if set to a true value instructs the browser to return the
 298 cookie only when a cryptographic protocol is in use.
 299
 300 =head2 Sending the Cookie to the Browser
 301
 302 Within a CGI script you can send a cookie to the browser by creating
 303 one or more Set-Cookie: fields in the HTTP header.  Here is a typical
 304 sequence:
 305
 306   my $c = new CGI::Cookie(-name    =>  'foo',
 307                           -value   =>  ['bar','baz'],
 308                           -expires =>  '+3M');
 309
 310   print "Set-Cookie: $c\n";
 311   print "Content-Type: text/html\n\n";
 312
 313 To send more than one cookie, create several Set-Cookie: fields.
 314 Alternatively, you may concatenate the cookies together with "; " and
 315 send them in one field.
 316
 317 If you are using CGI.pm, you send cookies by providing a -cookie
 318 argument to the header() method:
 319
 320   print header(-cookie=>$c);
 321
 322 Mod_perl users can set cookies using the request object's header_out()
 323 method:
 324
 325   $r->header_out('Set-Cookie',$c);
 326
 327 Internally, Cookie overloads the "" operator to call its as_string()
 328 method when incorporated into the HTTP header.  as_string() turns the
 329 Cookie's internal representation into an RFC-compliant text
 330 representation.  You may call as_string() yourself if you prefer:
 331
 332   print "Set-Cookie: ",$c->as_string,"\n";
 333
 334 =head2 Recovering Previous Cookies
 335
 336         %cookies = fetch CGI::Cookie;
 337
 338 B<fetch> returns an associative array consisting of all cookies
 339 returned by the browser.  The keys of the array are the cookie names.  You
 340 can iterate through the cookies this way:
 341
 342         %cookies = fetch CGI::Cookie;
 343         foreach (keys %cookies) {
 344            do_something($cookies{$_});
 345         }
 346
 347 In a scalar context, fetch() returns a hash reference, which may be more
 348 efficient if you are manipulating multiple cookies.
 349
 350 CGI.pm uses the URL escaping methods to save and restore reserved characters
 351 in its cookies.  If you are trying to retrieve a cookie set by a foreign server,
 352 this escaping method may trip you up.  Use raw_fetch() instead, which has the
 353 same semantics as fetch(), but performs no unescaping.
 354
 355 You may also retrieve cookies that were stored in some external
 356 form using the parse() class method:
 357
 358        $COOKIES = `cat /usr/tmp/Cookie_stash`;
 359        %cookies = parse CGI::Cookie($COOKIES);
 360
 361 =head2 Manipulating Cookies
 362
 363 Cookie objects have a series of accessor methods to get and set cookie
 364 attributes.  Each accessor has a similar syntax.  Called without
 365 arguments, the accessor returns the current value of the attribute.
 366 Called with an argument, the accessor changes the attribute and
 367 returns its new value.
 368
 369 =over 4
 370
 371 =item B<name()>
 372
 373 Get or set the cookie's name.  Example:
 374
 375         $name = $c->name;
 376         $new_name = $c->name('fred');
 377
 378 =item B<value()>
 379
 380 Get or set the cookie's value.  Example:
 381
 382         $value = $c->value;
 383         @new_value = $c->value(['a','b','c','d']);
 384
 385 B<value()> is context sensitive.  In an array context it will return
 386 the current value of the cookie as an array.  In a scalar context it
 387 will return the B<first> value of a multivalued cookie.
 388
 389 =item B<domain()>
 390
 391 Get or set the cookie's domain.
 392
 393 =item B<path()>
 394
 395 Get or set the cookie's path.
 396
 397 =item B<expires()>
 398
 399 Get or set the cookie's expiration time.
 400
 401 =back
 402
 403
 404 =head1 AUTHOR INFORMATION
 405
 406 Copyright 1997-1998, Lincoln D. Stein.  All rights reserved.
 407
 408 This library is free software; you can redistribute it and/or modify
 409 it under the same terms as Perl itself.
 410
 411 Address bug reports and comments to: lstein@cshl.org
 412
 413 =head1 BUGS
 414
 415 This section intentionally left blank.
 416
 417 =head1 SEE ALSO
 418
 419 L<CGI::Carp>, L<CGI>
 420
 421 =cut