Only 21 tests, skipping or not.
[p5sagit/p5-mst-13.2.git] / lib / CGI / Cookie.pm
CommitLineData
424ec8fa 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 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
199d4a26 16$CGI::Cookie::VERSION='1.20';
424ec8fa 17
3d1a2ec4 18use CGI::Util qw(rearrange unescape escape);
424ec8fa 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 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 55 }
56 return \%results unless wantarray;
57 return %results;
58}
59
424ec8fa 60
ba056755 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 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 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 85}
86
87sub new {
ba056755 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 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;
120 return $self;
424ec8fa 121}
122
123sub as_string {
124 my $self = shift;
125 return "" unless $self->name;
126
127 my(@constant_values,$domain,$path,$expires,$secure);
128
129 push(@constant_values,"domain=$domain") if $domain = $self->domain;
130 push(@constant_values,"path=$path") if $path = $self->path;
131 push(@constant_values,"expires=$expires") if $expires = $self->expires;
ba056755 132 push(@constant_values,"secure") if $secure = $self->secure;
424ec8fa 133
3d1a2ec4 134 my($key) = escape($self->name);
135 my($cookie) = join("=",$key,join("&",map escape($_),$self->value));
424ec8fa 136 return join("; ",$cookie,@constant_values);
137}
138
139sub compare {
140 my $self = shift;
141 my $value = shift;
142 return "$self" cmp $value;
143}
144
145# accessors
146sub name {
147 my $self = shift;
148 my $name = shift;
149 $self->{'name'} = $name if defined $name;
150 return $self->{'name'};
151}
152
153sub value {
154 my $self = shift;
155 my $value = shift;
156 $self->{'value'} = $value if defined $value;
157 return wantarray ? @{$self->{'value'}} : $self->{'value'}->[0]
158}
159
160sub domain {
161 my $self = shift;
162 my $domain = shift;
163 $self->{'domain'} = $domain if defined $domain;
164 return $self->{'domain'};
165}
166
167sub secure {
168 my $self = shift;
169 my $secure = shift;
170 $self->{'secure'} = $secure if defined $secure;
171 return $self->{'secure'};
172}
173
174sub expires {
175 my $self = shift;
176 my $expires = shift;
3d1a2ec4 177 $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires;
424ec8fa 178 return $self->{'expires'};
179}
180
181sub path {
182 my $self = shift;
183 my $path = shift;
184 $self->{'path'} = $path if defined $path;
185 return $self->{'path'};
186}
187
1881;
189
190=head1 NAME
191
192CGI::Cookie - Interface to Netscape Cookies
193
194=head1 SYNOPSIS
195
196 use CGI qw/:standard/;
197 use CGI::Cookie;
198
199 # Create new cookies and send them
200 $cookie1 = new CGI::Cookie(-name=>'ID',-value=>123456);
201 $cookie2 = new CGI::Cookie(-name=>'preferences',
202 -value=>{ font => Helvetica,
203 size => 12 }
204 );
205 print header(-cookie=>[$cookie1,$cookie2]);
206
207 # fetch existing cookies
208 %cookies = fetch CGI::Cookie;
209 $id = $cookies{'ID'}->value;
210
211 # create cookies returned from an external source
212 %cookies = parse CGI::Cookie($ENV{COOKIE});
213
214=head1 DESCRIPTION
215
216CGI::Cookie is an interface to Netscape (HTTP/1.1) cookies, an
217innovation that allows Web servers to store persistent information on
218the browser's side of the connection. Although CGI::Cookie is
219intended to be used in conjunction with CGI.pm (and is in fact used by
220it internally), you can use this module independently.
221
222For full information on cookies see
223
224 http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt
225
226=head1 USING CGI::Cookie
227
228CGI::Cookie is object oriented. Each cookie object has a name and a
229value. The name is any scalar value. The value is any scalar or
230array value (associative arrays are also allowed). Cookies also have
231several optional attributes, including:
232
233=over 4
234
235=item B<1. expiration date>
236
237The expiration date tells the browser how long to hang on to the
238cookie. If the cookie specifies an expiration date in the future, the
239browser will store the cookie information in a disk file and return it
240to the server every time the user reconnects (until the expiration
241date is reached). If the cookie species an expiration date in the
242past, the browser will remove the cookie from the disk file. If the
243expiration date is not specified, the cookie will persist only until
244the user quits the browser.
245
246=item B<2. domain>
247
248This is a partial or complete domain name for which the cookie is
249valid. The browser will return the cookie to any host that matches
250the partial domain name. For example, if you specify a domain name
251of ".capricorn.com", then Netscape will return the cookie to
252Web servers running on any of the machines "www.capricorn.com",
253"ftp.capricorn.com", "feckless.capricorn.com", etc. Domain names
254must contain at least two periods to prevent attempts to match
255on top level domains like ".edu". If no domain is specified, then
256the browser will only return the cookie to servers on the host the
257cookie originated from.
258
259=item B<3. path>
260
261If you provide a cookie path attribute, the browser will check it
262against your script's URL before returning the cookie. For example,
263if you specify the path "/cgi-bin", then the cookie will be returned
3538e1d5 264to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and
265"/cgi-bin/customer_service/complain.pl", but not to the script
3d1a2ec4 266"/cgi-private/site_admin.pl". By default, the path is set to "/", so
267that all scripts at your site will receive the cookie.
424ec8fa 268
269=item B<4. secure flag>
270
271If the "secure" attribute is set, the cookie will only be sent to your
272script if the CGI request is occurring on a secure channel, such as SSL.
273
274=back
275
276=head2 Creating New Cookies
277
278 $c = new CGI::Cookie(-name => 'foo',
279 -value => 'bar',
280 -expires => '+3M',
281 -domain => '.capricorn.com',
199d4a26 282 -path => '/cgi-bin/database',
424ec8fa 283 -secure => 1
284 );
285
286Create cookies from scratch with the B<new> method. The B<-name> and
287B<-value> parameters are required. The name must be a scalar value.
288The value can be a scalar, an array reference, or a hash reference.
289(At some point in the future cookies will support one of the Perl
290object serialization protocols for full generality).
291
292B<-expires> accepts any of the relative or absolute date formats
293recognized by CGI.pm, for example "+3M" for three months in the
294future. See CGI.pm's documentation for details.
295
296B<-domain> points to a domain name or to a fully qualified host name.
297If not specified, the cookie will be returned only to the Web server
298that created it.
299
300B<-path> points to a partial URL on the current server. The cookie
301will be returned to all URLs beginning with the specified path. If
302not specified, it defaults to '/', which returns the cookie to all
303pages at your site.
304
305B<-secure> if set to a true value instructs the browser to return the
306cookie only when a cryptographic protocol is in use.
307
308=head2 Sending the Cookie to the Browser
309
310Within a CGI script you can send a cookie to the browser by creating
311one or more Set-Cookie: fields in the HTTP header. Here is a typical
312sequence:
313
314 my $c = new CGI::Cookie(-name => 'foo',
315 -value => ['bar','baz'],
316 -expires => '+3M');
317
318 print "Set-Cookie: $c\n";
319 print "Content-Type: text/html\n\n";
320
321To send more than one cookie, create several Set-Cookie: fields.
322Alternatively, you may concatenate the cookies together with "; " and
323send them in one field.
324
325If you are using CGI.pm, you send cookies by providing a -cookie
326argument to the header() method:
327
328 print header(-cookie=>$c);
329
330Mod_perl users can set cookies using the request object's header_out()
331method:
332
333 $r->header_out('Set-Cookie',$c);
334
335Internally, Cookie overloads the "" operator to call its as_string()
336method when incorporated into the HTTP header. as_string() turns the
337Cookie's internal representation into an RFC-compliant text
338representation. You may call as_string() yourself if you prefer:
339
340 print "Set-Cookie: ",$c->as_string,"\n";
341
342=head2 Recovering Previous Cookies
343
344 %cookies = fetch CGI::Cookie;
345
346B<fetch> returns an associative array consisting of all cookies
347returned by the browser. The keys of the array are the cookie names. You
348can iterate through the cookies this way:
349
350 %cookies = fetch CGI::Cookie;
351 foreach (keys %cookies) {
352 do_something($cookies{$_});
353 }
354
355In a scalar context, fetch() returns a hash reference, which may be more
356efficient if you are manipulating multiple cookies.
3cb6de81 357
424ec8fa 358CGI.pm uses the URL escaping methods to save and restore reserved characters
359in its cookies. If you are trying to retrieve a cookie set by a foreign server,
360this escaping method may trip you up. Use raw_fetch() instead, which has the
361same semantics as fetch(), but performs no unescaping.
362
363You may also retrieve cookies that were stored in some external
364form using the parse() class method:
365
366 $COOKIES = `cat /usr/tmp/Cookie_stash`;
367 %cookies = parse CGI::Cookie($COOKIES);
368
369=head2 Manipulating Cookies
370
371Cookie objects have a series of accessor methods to get and set cookie
372attributes. Each accessor has a similar syntax. Called without
373arguments, the accessor returns the current value of the attribute.
374Called with an argument, the accessor changes the attribute and
375returns its new value.
376
377=over 4
378
379=item B<name()>
380
381Get or set the cookie's name. Example:
382
383 $name = $c->name;
384 $new_name = $c->name('fred');
385
386=item B<value()>
387
388Get or set the cookie's value. Example:
389
390 $value = $c->value;
391 @new_value = $c->value(['a','b','c','d']);
392
a3b3a725 393B<value()> is context sensitive. In a list context it will return
424ec8fa 394the current value of the cookie as an array. In a scalar context it
395will return the B<first> value of a multivalued cookie.
396
397=item B<domain()>
398
399Get or set the cookie's domain.
400
401=item B<path()>
402
403Get or set the cookie's path.
404
405=item B<expires()>
406
407Get or set the cookie's expiration time.
408
409=back
410
411
412=head1 AUTHOR INFORMATION
413
71f3e297 414Copyright 1997-1998, Lincoln D. Stein. All rights reserved.
424ec8fa 415
71f3e297 416This library is free software; you can redistribute it and/or modify
417it under the same terms as Perl itself.
418
419Address bug reports and comments to: lstein@cshl.org
424ec8fa 420
421=head1 BUGS
422
423This section intentionally left blank.
424
425=head1 SEE ALSO
426
427L<CGI::Carp>, L<CGI>
3cb6de81 428
424ec8fa 429=cut