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