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