File Coverage

blib/lib/CGI/Simple/Cookie.pm
Criterion Covered Total %
statement 87 87 100.0
branch 44 52 84.6
condition 11 16 68.8
subroutine 16 16 100.0
pod 6 12 50.0
total 164 183 89.6


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