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