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