File Coverage

blib/lib/CGI/Cookie.pm
Criterion Covered Total %
statement 125 127 98.4
branch 76 94 80.8
condition 13 29 44.8
subroutine 23 23 100.0
pod 9 17 52.9
total 246 290 84.8


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