← Index
NYTProf Performance Profile   « line view »
For ./view
  Run on Fri Jul 31 19:05:14 2015
Reported on Fri Jul 31 19:08:10 2015

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