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