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