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