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 |
|
---|
10 | # Copyright 1995-1999, Lincoln D. Stein. All rights reserved.
|
---|
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 |
|
---|
16 | $CGI::Cookie::VERSION='1.26';
|
---|
17 |
|
---|
18 | use CGI::Util qw(rearrange unescape escape);
|
---|
19 | use overload '""' => \&as_string,
|
---|
20 | 'cmp' => \&compare,
|
---|
21 | 'fallback'=>1;
|
---|
22 |
|
---|
23 | # Turn on special checking for Doug MacEachern's modperl
|
---|
24 | my $MOD_PERL = 0;
|
---|
25 | if (exists $ENV{MOD_PERL}) {
|
---|
26 | if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
|
---|
27 | $MOD_PERL = 2;
|
---|
28 | require Apache2::RequestUtil;
|
---|
29 | require APR::Table;
|
---|
30 | } else {
|
---|
31 | $MOD_PERL = 1;
|
---|
32 | require Apache;
|
---|
33 | }
|
---|
34 | }
|
---|
35 |
|
---|
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.
|
---|
39 | sub fetch {
|
---|
40 | my $class = shift;
|
---|
41 | my $raw_cookie = get_raw_cookie(@_) or return;
|
---|
42 | return $class->parse($raw_cookie);
|
---|
43 | }
|
---|
44 |
|
---|
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 |
|
---|
70 | sub get_raw_cookie {
|
---|
71 | my $r = shift;
|
---|
72 | $r ||= eval { $MOD_PERL == 2 ?
|
---|
73 | Apache2::RequestUtil->request() :
|
---|
74 | Apache->request } if $MOD_PERL;
|
---|
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()";
|
---|
80 | }
|
---|
81 | $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
|
---|
82 | }
|
---|
83 | }
|
---|
84 |
|
---|
85 |
|
---|
86 | sub parse {
|
---|
87 | my ($self,$raw_cookie) = @_;
|
---|
88 | my %results;
|
---|
89 |
|
---|
90 | my(@pairs) = split("; ?",$raw_cookie);
|
---|
91 | foreach (@pairs) {
|
---|
92 | s/\s*(.*?)\s*/$1/;
|
---|
93 | my($key,$value) = split("=",$_,2);
|
---|
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 '') {
|
---|
100 | @values = map unescape($_),split(/[&;]/,$value.'&dmy');
|
---|
101 | pop @values;
|
---|
102 | }
|
---|
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;
|
---|
110 | }
|
---|
111 |
|
---|
112 | sub new {
|
---|
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;
|
---|
125 | }
|
---|
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;
|
---|
145 | # $self->max_age($expires) if defined $expires;
|
---|
146 | return $self;
|
---|
147 | }
|
---|
148 |
|
---|
149 | sub as_string {
|
---|
150 | my $self = shift;
|
---|
151 | return "" unless $self->name;
|
---|
152 |
|
---|
153 | my(@constant_values,$domain,$path,$expires,$max_age,$secure);
|
---|
154 |
|
---|
155 | push(@constant_values,"domain=$domain") if $domain = $self->domain;
|
---|
156 | push(@constant_values,"path=$path") if $path = $self->path;
|
---|
157 | push(@constant_values,"expires=$expires") if $expires = $self->expires;
|
---|
158 | push(@constant_values,"max-age=$max_age") if $max_age = $self->max_age;
|
---|
159 | push(@constant_values,"secure") if $secure = $self->secure;
|
---|
160 |
|
---|
161 | my($key) = escape($self->name);
|
---|
162 | my($cookie) = join("=",($key||''),join("&",map escape($_||''),$self->value));
|
---|
163 | return join("; ",$cookie,@constant_values);
|
---|
164 | }
|
---|
165 |
|
---|
166 | sub compare {
|
---|
167 | my $self = shift;
|
---|
168 | my $value = shift;
|
---|
169 | return "$self" cmp $value;
|
---|
170 | }
|
---|
171 |
|
---|
172 | # accessors
|
---|
173 | sub name {
|
---|
174 | my $self = shift;
|
---|
175 | my $name = shift;
|
---|
176 | $self->{'name'} = $name if defined $name;
|
---|
177 | return $self->{'name'};
|
---|
178 | }
|
---|
179 |
|
---|
180 | sub value {
|
---|
181 | my $self = shift;
|
---|
182 | my $value = shift;
|
---|
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 | }
|
---|
196 | return wantarray ? @{$self->{'value'}} : $self->{'value'}->[0]
|
---|
197 | }
|
---|
198 |
|
---|
199 | sub domain {
|
---|
200 | my $self = shift;
|
---|
201 | my $domain = shift;
|
---|
202 | $self->{'domain'} = lc $domain if defined $domain;
|
---|
203 | return $self->{'domain'};
|
---|
204 | }
|
---|
205 |
|
---|
206 | sub secure {
|
---|
207 | my $self = shift;
|
---|
208 | my $secure = shift;
|
---|
209 | $self->{'secure'} = $secure if defined $secure;
|
---|
210 | return $self->{'secure'};
|
---|
211 | }
|
---|
212 |
|
---|
213 | sub expires {
|
---|
214 | my $self = shift;
|
---|
215 | my $expires = shift;
|
---|
216 | $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires;
|
---|
217 | return $self->{'expires'};
|
---|
218 | }
|
---|
219 |
|
---|
220 | sub max_age {
|
---|
221 | my $self = shift;
|
---|
222 | my $expires = shift;
|
---|
223 | $self->{'max-age'} = CGI::Util::expire_calc($expires)-time() if defined $expires;
|
---|
224 | return $self->{'max-age'};
|
---|
225 | }
|
---|
226 |
|
---|
227 | sub path {
|
---|
228 | my $self = shift;
|
---|
229 | my $path = shift;
|
---|
230 | $self->{'path'} = $path if defined $path;
|
---|
231 | return $self->{'path'};
|
---|
232 | }
|
---|
233 |
|
---|
234 | 1;
|
---|
235 |
|
---|
236 | =head1 NAME
|
---|
237 |
|
---|
238 | CGI::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 |
|
---|
262 | CGI::Cookie is an interface to Netscape (HTTP/1.1) cookies, an
|
---|
263 | innovation that allows Web servers to store persistent information on
|
---|
264 | the browser's side of the connection. Although CGI::Cookie is
|
---|
265 | intended to be used in conjunction with CGI.pm (and is in fact used by
|
---|
266 | it internally), you can use this module independently.
|
---|
267 |
|
---|
268 | For full information on cookies see
|
---|
269 |
|
---|
270 | http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt
|
---|
271 |
|
---|
272 | =head1 USING CGI::Cookie
|
---|
273 |
|
---|
274 | CGI::Cookie is object oriented. Each cookie object has a name and a
|
---|
275 | value. The name is any scalar value. The value is any scalar or
|
---|
276 | array value (associative arrays are also allowed). Cookies also have
|
---|
277 | several optional attributes, including:
|
---|
278 |
|
---|
279 | =over 4
|
---|
280 |
|
---|
281 | =item B<1. expiration date>
|
---|
282 |
|
---|
283 | The expiration date tells the browser how long to hang on to the
|
---|
284 | cookie. If the cookie specifies an expiration date in the future, the
|
---|
285 | browser will store the cookie information in a disk file and return it
|
---|
286 | to the server every time the user reconnects (until the expiration
|
---|
287 | date is reached). If the cookie species an expiration date in the
|
---|
288 | past, the browser will remove the cookie from the disk file. If the
|
---|
289 | expiration date is not specified, the cookie will persist only until
|
---|
290 | the user quits the browser.
|
---|
291 |
|
---|
292 | =item B<2. domain>
|
---|
293 |
|
---|
294 | This is a partial or complete domain name for which the cookie is
|
---|
295 | valid. The browser will return the cookie to any host that matches
|
---|
296 | the partial domain name. For example, if you specify a domain name
|
---|
297 | of ".capricorn.com", then Netscape will return the cookie to
|
---|
298 | Web servers running on any of the machines "www.capricorn.com",
|
---|
299 | "ftp.capricorn.com", "feckless.capricorn.com", etc. Domain names
|
---|
300 | must contain at least two periods to prevent attempts to match
|
---|
301 | on top level domains like ".edu". If no domain is specified, then
|
---|
302 | the browser will only return the cookie to servers on the host the
|
---|
303 | cookie originated from.
|
---|
304 |
|
---|
305 | =item B<3. path>
|
---|
306 |
|
---|
307 | If you provide a cookie path attribute, the browser will check it
|
---|
308 | against your script's URL before returning the cookie. For example,
|
---|
309 | if you specify the path "/cgi-bin", then the cookie will be returned
|
---|
310 | to 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
|
---|
312 | "/cgi-private/site_admin.pl". By default, the path is set to "/", so
|
---|
313 | that all scripts at your site will receive the cookie.
|
---|
314 |
|
---|
315 | =item B<4. secure flag>
|
---|
316 |
|
---|
317 | If the "secure" attribute is set, the cookie will only be sent to your
|
---|
318 | script 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',
|
---|
328 | -path => '/cgi-bin/database',
|
---|
329 | -secure => 1
|
---|
330 | );
|
---|
331 |
|
---|
332 | Create cookies from scratch with the B<new> method. The B<-name> and
|
---|
333 | B<-value> parameters are required. The name must be a scalar value.
|
---|
334 | The 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
|
---|
336 | object serialization protocols for full generality).
|
---|
337 |
|
---|
338 | B<-expires> accepts any of the relative or absolute date formats
|
---|
339 | recognized by CGI.pm, for example "+3M" for three months in the
|
---|
340 | future. See CGI.pm's documentation for details.
|
---|
341 |
|
---|
342 | B<-domain> points to a domain name or to a fully qualified host name.
|
---|
343 | If not specified, the cookie will be returned only to the Web server
|
---|
344 | that created it.
|
---|
345 |
|
---|
346 | B<-path> points to a partial URL on the current server. The cookie
|
---|
347 | will be returned to all URLs beginning with the specified path. If
|
---|
348 | not specified, it defaults to '/', which returns the cookie to all
|
---|
349 | pages at your site.
|
---|
350 |
|
---|
351 | B<-secure> if set to a true value instructs the browser to return the
|
---|
352 | cookie only when a cryptographic protocol is in use.
|
---|
353 |
|
---|
354 | =head2 Sending the Cookie to the Browser
|
---|
355 |
|
---|
356 | Within a CGI script you can send a cookie to the browser by creating
|
---|
357 | one or more Set-Cookie: fields in the HTTP header. Here is a typical
|
---|
358 | sequence:
|
---|
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 |
|
---|
367 | To send more than one cookie, create several Set-Cookie: fields.
|
---|
368 |
|
---|
369 | If you are using CGI.pm, you send cookies by providing a -cookie
|
---|
370 | argument to the header() method:
|
---|
371 |
|
---|
372 | print header(-cookie=>$c);
|
---|
373 |
|
---|
374 | Mod_perl users can set cookies using the request object's header_out()
|
---|
375 | method:
|
---|
376 |
|
---|
377 | $r->headers_out->set('Set-Cookie' => $c);
|
---|
378 |
|
---|
379 | Internally, Cookie overloads the "" operator to call its as_string()
|
---|
380 | method when incorporated into the HTTP header. as_string() turns the
|
---|
381 | Cookie's internal representation into an RFC-compliant text
|
---|
382 | representation. 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 |
|
---|
390 | B<fetch> returns an associative array consisting of all cookies
|
---|
391 | returned by the browser. The keys of the array are the cookie names. You
|
---|
392 | can iterate through the cookies this way:
|
---|
393 |
|
---|
394 | %cookies = fetch CGI::Cookie;
|
---|
395 | foreach (keys %cookies) {
|
---|
396 | do_something($cookies{$_});
|
---|
397 | }
|
---|
398 |
|
---|
399 | In a scalar context, fetch() returns a hash reference, which may be more
|
---|
400 | efficient if you are manipulating multiple cookies.
|
---|
401 |
|
---|
402 | CGI.pm uses the URL escaping methods to save and restore reserved characters
|
---|
403 | in its cookies. If you are trying to retrieve a cookie set by a foreign server,
|
---|
404 | this escaping method may trip you up. Use raw_fetch() instead, which has the
|
---|
405 | same semantics as fetch(), but performs no unescaping.
|
---|
406 |
|
---|
407 | You may also retrieve cookies that were stored in some external
|
---|
408 | form using the parse() class method:
|
---|
409 |
|
---|
410 | $COOKIES = `cat /usr/tmp/Cookie_stash`;
|
---|
411 | %cookies = parse CGI::Cookie($COOKIES);
|
---|
412 |
|
---|
413 | If you are in a mod_perl environment, you can save some overhead by
|
---|
414 | passing the request object to fetch() like this:
|
---|
415 |
|
---|
416 | CGI::Cookie->fetch($r);
|
---|
417 |
|
---|
418 | =head2 Manipulating Cookies
|
---|
419 |
|
---|
420 | Cookie objects have a series of accessor methods to get and set cookie
|
---|
421 | attributes. Each accessor has a similar syntax. Called without
|
---|
422 | arguments, the accessor returns the current value of the attribute.
|
---|
423 | Called with an argument, the accessor changes the attribute and
|
---|
424 | returns its new value.
|
---|
425 |
|
---|
426 | =over 4
|
---|
427 |
|
---|
428 | =item B<name()>
|
---|
429 |
|
---|
430 | Get or set the cookie's name. Example:
|
---|
431 |
|
---|
432 | $name = $c->name;
|
---|
433 | $new_name = $c->name('fred');
|
---|
434 |
|
---|
435 | =item B<value()>
|
---|
436 |
|
---|
437 | Get or set the cookie's value. Example:
|
---|
438 |
|
---|
439 | $value = $c->value;
|
---|
440 | @new_value = $c->value(['a','b','c','d']);
|
---|
441 |
|
---|
442 | B<value()> is context sensitive. In a list context it will return
|
---|
443 | the current value of the cookie as an array. In a scalar context it
|
---|
444 | will return the B<first> value of a multivalued cookie.
|
---|
445 |
|
---|
446 | =item B<domain()>
|
---|
447 |
|
---|
448 | Get or set the cookie's domain.
|
---|
449 |
|
---|
450 | =item B<path()>
|
---|
451 |
|
---|
452 | Get or set the cookie's path.
|
---|
453 |
|
---|
454 | =item B<expires()>
|
---|
455 |
|
---|
456 | Get or set the cookie's expiration time.
|
---|
457 |
|
---|
458 | =back
|
---|
459 |
|
---|
460 |
|
---|
461 | =head1 AUTHOR INFORMATION
|
---|
462 |
|
---|
463 | Copyright 1997-1998, Lincoln D. Stein. All rights reserved.
|
---|
464 |
|
---|
465 | This library is free software; you can redistribute it and/or modify
|
---|
466 | it under the same terms as Perl itself.
|
---|
467 |
|
---|
468 | Address bug reports and comments to: [email protected]
|
---|
469 |
|
---|
470 | =head1 BUGS
|
---|
471 |
|
---|
472 | This section intentionally left blank.
|
---|
473 |
|
---|
474 | =head1 SEE ALSO
|
---|
475 |
|
---|
476 | L<CGI::Carp>, L<CGI>
|
---|
477 |
|
---|
478 | =cut
|
---|