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