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