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