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