cpan/CGI/lib/CGI/Cookie.pm

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