File Coverage

blib/lib/CGI/Cookie.pm
Criterion Covered Total %
statement 120 130 92.3
branch 60 92 65.2
condition 10 20 50.0
subroutine 19 19 100.0
pod 7 16 43.8
total 216 277 78.0


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