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