File Coverage

blib/lib/HTTP/Cookies.pm
Criterion Covered Total %
statement 344 370 92.9
branch 176 216 81.4
condition 54 71 76.0
subroutine 22 23 95.6
pod 12 13 92.3
total 608 693 87.7


line stmt bran cond sub pod time code
1             package HTTP::Cookies;
2              
3 6     6   284504 use strict;
  6         55  
  6         184  
4 6     6   2345 use HTTP::Date qw(str2time parse_date time2str);
  6         22202  
  6         347  
5 6     6   2203 use HTTP::Headers::Util qw(_split_header_words join_header_words);
  6         5080  
  6         21427  
6              
7             our $EPOCH_OFFSET;
8             our $VERSION = '6.08';
9              
10             # Legacy: because "use "HTTP::Cookies" used be the ONLY way
11             # to load the class HTTP::Cookies::Netscape.
12             require HTTP::Cookies::Netscape;
13              
14             $EPOCH_OFFSET = 0; # difference from Unix epoch
15              
16             # A HTTP::Cookies object is a hash. The main attribute is the
17             # COOKIES 3 level hash: $self->{COOKIES}{$domain}{$path}{$key}.
18              
19             sub new
20             {
21 31     31 1 9412 my $class = shift;
22 31         86 my $self = bless {
23             COOKIES => {},
24             }, $class;
25 31         69 my %cnf = @_;
26 31         79 for (keys %cnf) {
27 6         22 $self->{lc($_)} = $cnf{$_};
28             }
29 31         88 $self->load;
30 31         117 $self;
31             }
32              
33              
34             sub add_cookie_header
35             {
36 70     70 1 22445 my $self = shift;
37 70   50     143 my $request = shift || return;
38 70         131 my $url = $request->uri;
39 70         450 my $scheme = $url->scheme;
40 70 100       1123 unless ($scheme =~ /^https?\z/) {
41 3         6 return;
42             }
43              
44 67         126 my $domain = _host($request, $url);
45 67 100       1344 $domain = "$domain.local" unless $domain =~ /\./;
46 67         98 my $secure_request = ($scheme eq "https");
47 67         95 my $req_path = _url_path($url);
48 67         136 my $req_port = $url->port;
49 67         1297 my $now = time();
50 67 100       417 _normalize_path($req_path) if $req_path =~ /%/;
51              
52 67         86 my @cval; # cookie values for the "Cookie" header
53             my $set_ver;
54 67         75 my $netscape_only = 0; # An exact domain match applies to any cookie
55              
56 67         127 while ($domain =~ /\./) {
57             # Checking $domain for cookies"
58 252         362 my $cookies = $self->{COOKIES}{$domain};
59 252 100       366 next unless $cookies;
60 57 50 33     98 if ($self->{delayload} && defined($cookies->{'//+delayload'})) {
61 0         0 my $cookie_data = $cookies->{'//+delayload'}{'cookie'};
62 0         0 delete $self->{COOKIES}{$domain};
63 0         0 $self->load_cookie($cookie_data->[1]);
64 0         0 $cookies = $self->{COOKIES}{$domain};
65 0 0       0 next unless $cookies; # should not really happen
66             }
67              
68             # Want to add cookies corresponding to the most specific paths
69             # first (i.e. longest path first)
70 57         80 my $path;
71 57         163 for $path (sort {length($b) <=> length($a) } keys %$cookies) {
  10         28  
72 67 100       154 if (index($req_path, $path) != 0) {
73 7         11 next;
74             }
75              
76 60         71 my($key,$array);
77 60         72 while (($key,$array) = each %{$cookies->{$path}}) {
  135         371  
78 75         153 my($version,$val,$port,$path_spec,$secure,$expires) = @$array;
79 75 100 100     168 if ($secure && !$secure_request) {
80 1         2 next;
81             }
82 74 50 66     145 if ($expires && $expires < $now) {
83 0         0 next;
84             }
85 74 100       103 if ($port) {
86 7         7 my $found;
87 7 100       18 if ($port =~ s/^_//) {
88             # The corresponding Set-Cookie attribute was empty
89 4 50       9 $found++ if $port eq $req_port;
90 4         15 $port = "";
91             }
92             else {
93 3         4 my $p;
94 3         9 for $p (split(/,/, $port)) {
95 7 100       14 $found++, last if $p eq $req_port;
96             }
97             }
98 7 50       14 unless ($found) {
99 0         0 next;
100             }
101             }
102 74 50 66     174 if ($version > 0 && $netscape_only) {
103 0         0 next;
104             }
105              
106             # set version number of cookie header.
107             # XXX: What should it be if multiple matching
108             # Set-Cookie headers have different versions themselves
109 74 100       134 if (!$set_ver++) {
110 50 100       106 if ($version >= 1) {
    50          
111 18         40 push(@cval, "\$Version=$version");
112             }
113             elsif (!$self->{hide_cookie2}) {
114 32         65 $request->header(Cookie2 => '$Version="1"');
115             }
116             }
117              
118             # do we need to quote the value
119 74 50 66     1745 if ($val =~ /\W/ && $version) {
120 0         0 $val =~ s/([\\\"])/\\$1/g;
121 0         0 $val = qq("$val");
122             }
123              
124             # and finally remember this cookie
125 74         146 push(@cval, "$key=$val");
126 74 100       131 if ($version >= 1) {
127 31 100       49 push(@cval, qq(\$Path="$path")) if $path_spec;
128 31 100       60 push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./;
129 31 100       67 if (defined $port) {
130 7         10 my $p = '$Port';
131 7 100       23 $p .= qq(="$port") if length $port;
132 7         10 push(@cval, $p);
133             }
134             }
135              
136             }
137             }
138              
139             } continue {
140             # Try with a more general domain, alternately stripping
141             # leading name components and leading dots. When this
142             # results in a domain with no leading dot, it is for
143             # Netscape cookie compatibility only:
144             #
145             # a.b.c.net Any cookie
146             # .b.c.net Any cookie
147             # b.c.net Netscape cookie only
148             # .c.net Any cookie
149              
150 252 100       524 if ($domain =~ s/^\.+//) {
151 126         257 $netscape_only = 1;
152             }
153             else {
154 126         356 $domain =~ s/[^.]*//;
155 126         273 $netscape_only = 0;
156             }
157             }
158              
159 67 100       120 if (@cval) {
160 50 100       106 if (my $old = $request->header("Cookie")) {
161 2         68 unshift(@cval, $old);
162             }
163 50         2074 $request->header(Cookie => join("; ", @cval));
164 50 100       1945 if (my $hash = $request->{_http_cookies}) {
165 8         34 %$hash = (map split(/=/, $_, 2), @cval);
166             }
167             }
168              
169 67         142 $request;
170             }
171              
172              
173             sub get_cookies
174             {
175 9     9 1 71 my $self = shift;
176 9         13 my $url = shift;
177 9 100       33 $url = "https://$url" unless $url =~ m,^[a-zA-Z][a-zA-Z0-9.+\-]*:,;
178 9         44 require HTTP::Request;
179 9         25 my $req = HTTP::Request->new(GET => $url);
180 9         796 my $cookies = $req->{_http_cookies} = {};
181 9         22 $self->add_cookie_header($req);
182 9 100       14 if (@_) {
183 8 100       22 return map $cookies->{$_}, @_ if wantarray;
184 7         40 return $cookies->{$_[0]};
185             }
186 1         7 return $cookies;
187             }
188              
189              
190             sub extract_cookies
191             {
192 69     69 1 50771 my $self = shift;
193 69   50     150 my $response = shift || return;
194              
195 69         176 my @set = _split_header_words($response->_header("Set-Cookie2"));
196 69         3893 my @ns_set = $response->_header("Set-Cookie");
197              
198 69 100 100     1903 return $response unless @set || @ns_set; # quick exit
199              
200 62         142 my $request = $response->request;
201 62         545 my $url = $request->uri;
202 62         418 my $req_host = _host($request, $url);
203 62 100       1298 $req_host = "$req_host.local" unless $req_host =~ /\./;
204 62         134 my $req_port = $url->port;
205 62         1470 my $req_path = _url_path($url);
206 62 100       133 _normalize_path($req_path) if $req_path =~ /%/;
207              
208 62 100       111 if (@ns_set) {
209             # The old Netscape cookie format for Set-Cookie
210             # http://curl.haxx.se/rfc/cookie_spec.html
211             # can for instance contain an unquoted "," in the expires
212             # field, so we have to use this ad-hoc parser.
213 32         49 my $now = time();
214              
215             # Build a hash of cookies that was present in Set-Cookie2
216             # headers. We need to skip them if we also find them in a
217             # Set-Cookie header.
218 32         33 my %in_set2;
219 32         48 for (@set) {
220 2         7 $in_set2{$_->[0]}++;
221             }
222              
223 32         36 my $set;
224 32         45 for $set (@ns_set) {
225 42         76 $set =~ s/^\s+//;
226 42         76 my @cur;
227             my $param;
228 42         0 my $expires;
229 42         55 my $first_param = 1;
230 42         49 for $param (@{_split_text($set)}) {
  42         72  
231 106 100       166 next unless length($param);
232 105         314 my($k,$v) = split(/\s*=\s*/, $param, 2);
233 105 100       183 if (defined $v) {
234 103         163 $v =~ s/\s+$//;
235             #print "$k => $v\n";
236             }
237             else {
238 2         4 $k =~ s/\s+$//;
239             #print "$k => undef";
240             }
241 105 100 100     408 if (!$first_param && lc($k) eq "expires") {
    100 100        
242 14         64 my $etime = str2time($v);
243 14 100       1143 if (defined $etime) {
244 12         30 push(@cur, "Max-Age" => $etime - $now);
245 12         18 $expires++;
246             }
247             else {
248             # parse_date can deal with years outside the range of time_t,
249 2         5 my($year, $mon, $day, $hour, $min, $sec, $tz) = parse_date($v);
250 2 50       50 if ($year) {
251 2         10 my $thisyear = (gmtime)[5] + 1900;
252 2 50       6 if ($year < $thisyear) {
    0          
253 2         3 push(@cur, "Max-Age" => -1); # any negative value will do
254 2         4 $expires++;
255             }
256             elsif ($year >= $thisyear + 10) {
257             # the date is at least 10 years into the future, just replace
258             # it with something approximate
259 0         0 push(@cur, "Max-Age" => 10 * 365 * 24 * 60 * 60);
260 0         0 $expires++;
261             }
262             }
263             }
264             }
265             elsif (!$first_param && lc($k) =~ /^(?:version|discard|ns-cookie)/) {
266             # ignore
267             }
268             else {
269 89         146 push(@cur, $k => $v);
270             }
271 105         157 $first_param = 0;
272             }
273 42 100       91 next unless @cur;
274 41 100       79 next if $in_set2{$cur[0]};
275              
276             # push(@cur, "Port" => $req_port);
277 40 100       82 push(@cur, "Discard" => undef) unless $expires;
278 40         59 push(@cur, "Version" => 0);
279 40         57 push(@cur, "ns-cookie" => 1);
280 40         83 push(@set, \@cur);
281             }
282             }
283              
284             SET_COOKIE:
285 62         99 for my $set (@set) {
286 76 50       132 next unless @$set >= 2;
287              
288 76         108 my $key = shift @$set;
289 76         99 my $val = shift @$set;
290              
291 76         92 my %hash;
292 76         131 while (@$set) {
293 234         273 my $k = shift @$set;
294 234         281 my $v = shift @$set;
295 234         302 my $lc = lc($k);
296             # don't loose case distinction for unknown fields
297 234 100       609 $k = $lc if $lc =~ /^(?:discard|domain|max-age|
298             path|port|secure|version)$/x;
299 234 100 100     578 if ($k eq "discard" || $k eq "secure") {
300 33 50       61 $v = 1 unless defined $v;
301             }
302 234 50       360 next if exists $hash{$k}; # only first value is significant
303 234         460 $hash{$k} = $v;
304             };
305              
306 76         259 my %orig_hash = %hash;
307 76         145 my $version = delete $hash{version};
308 76 100       125 $version = 1 unless defined($version);
309 76         90 my $discard = delete $hash{discard};
310 76         94 my $secure = delete $hash{secure};
311 76         91 my $maxage = delete $hash{'max-age'};
312 76         99 my $ns_cookie = delete $hash{'ns-cookie'};
313              
314             # Check domain
315 76         88 my $domain = delete $hash{domain};
316 76 100       121 $domain = lc($domain) if defined $domain;
317 76 100 100     220 if (defined($domain)
      100        
318             && $domain ne $req_host && $domain ne ".$req_host") {
319 17 50 33     44 if ($domain !~ /\./ && $domain ne "local") {
320 0         0 next SET_COOKIE;
321             }
322 17 100       40 $domain = ".$domain" unless $domain =~ /^\./;
323 17 100       49 if ($domain =~ /\.\d+$/) {
324 1         4 next SET_COOKIE;
325             }
326 16         20 my $len = length($domain);
327 16 50       44 unless (substr($req_host, -$len) eq $domain) {
328 0         0 next SET_COOKIE;
329             }
330 16         28 my $hostpre = substr($req_host, 0, length($req_host) - $len);
331 16 100 100     42 if ($hostpre =~ /\./ && !$ns_cookie) {
332 2         7 next SET_COOKIE;
333             }
334             }
335             else {
336 59         76 $domain = $req_host;
337             }
338              
339 73         95 my $path = delete $hash{path};
340 73         82 my $path_spec;
341 73 100 100     192 if (defined $path && $path ne '') {
342 49         65 $path_spec++;
343 49 100       92 _normalize_path($path) if $path =~ /%/;
344 49 100 100     134 if (!$ns_cookie &&
345             substr($req_path, 0, length($path)) ne $path) {
346 4         13 next SET_COOKIE;
347             }
348             }
349             else {
350 24         34 $path = $req_path;
351 24         75 $path =~ s,/[^/]*$,,;
352 24 100       56 $path = "/" unless length($path);
353             }
354              
355 69         78 my $port;
356 69 100       120 if (exists $hash{port}) {
357 5         9 $port = delete $hash{port};
358 5 100       7 if (defined $port) {
359 3         8 $port =~ s/\s+//g;
360 3         4 my $found;
361 3         8 for my $p (split(/,/, $port)) {
362 7 50       26 unless ($p =~ /^\d+$/) {
363 0         0 next SET_COOKIE;
364             }
365 7 100       17 $found++ if $p eq $req_port;
366             }
367 3 100       11 unless ($found) {
368 1         5 next SET_COOKIE;
369             }
370             }
371             else {
372 2         4 $port = "_$req_port";
373             }
374             }
375 68 50       135 $self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash)
376             if $self->set_cookie_ok(\%orig_hash);
377             }
378              
379 62         143 $response;
380             }
381              
382             sub set_cookie_ok
383             {
384 68     68 0 180 1;
385             }
386              
387              
388             sub set_cookie
389             {
390 73     73 1 92 my $self = shift;
391 73         170 my($version,
392             $key, $val, $path, $domain, $port,
393             $path_spec, $secure, $maxage, $discard, $rest) = @_;
394              
395             # path and key can not be empty (key can't start with '$')
396 73 50 33     443 return $self if !defined($path) || $path !~ m,^/, ||
      33        
397             !defined($key) || $key =~ m,^\$,;
398              
399             # ensure legal port
400 73 100       109 if (defined $port) {
401 4 50       14 return $self unless $port =~ /^_?\d+(?:,\d+)*$/;
402             }
403              
404 73         88 my $expires;
405 73 100       125 if (defined $maxage) {
406 23 100       72 if ($maxage <= 0) {
407 8         12 delete $self->{COOKIES}{$domain}{$path}{$key};
408 8         26 return $self;
409             }
410 15         21 $expires = time() + $maxage;
411             }
412 65 100       104 $version = 0 unless defined $version;
413              
414 65         159 my @array = ($version, $val,$port,
415             $path_spec,
416             $secure, $expires, $discard);
417 65 100 100     187 push(@array, {%$rest}) if defined($rest) && %$rest;
418             # trim off undefined values at end
419 65         166 pop(@array) while !defined $array[-1];
420              
421 65         200 $self->{COOKIES}{$domain}{$path}{$key} = \@array;
422 65         228 $self;
423             }
424              
425              
426             sub save
427             {
428 2     2 1 88 my $self = shift;
429             my %args = (
430             file => $self->{'file'},
431 2 100       14 ignore_discard => $self->{'ignore_discard'},
432             @_ == 1 ? ( file => $_[0] ) : @_
433             );
434 2 50       7 Carp::croak('Unexpected argument to save method') if keys %args > 2;
435 2   50     6 my $file = $args{'file'} || return;
436 2 50       206 open(my $fh, '>', $file) or die "Can't open $file: $!";
437 2         6 print {$fh} "#LWP-Cookies-1.0\n";
  2         32  
438 2         5 print {$fh} $self->as_string(!$args{'ignore_discard'});
  2         9  
439 2 50       97 close $fh or die "Can't close $file: $!";
440 2         13 1;
441             }
442              
443              
444             sub load
445             {
446 29     29 1 41 my $self = shift;
447 29   50     135 my $file = shift || $self->{'file'} || return;
448              
449 2         7 local $/ = "\n"; # make sure we got standard record separator
450 2 50       60 open(my $fh, '<', $file) or return;
451              
452             # check that we have the proper header
453 2         38 my $magic = <$fh>;
454 2         8 chomp $magic;
455 2 50       11 unless ($magic =~ /^#LWP-Cookies-\d+\.\d+/) {
456 0         0 warn "$file does not seem to contain cookies";
457 0         0 return;
458             }
459              
460             # go through the file
461 2         8 while (my $line = <$fh>) {
462 7         12 chomp $line;
463 7 50       27 next unless $line =~ s/^Set-Cookie3:\s*//;
464 7         10 my $cookie;
465 7         15 for $cookie (_split_header_words($line)) {
466 7         563 my($key,$val) = splice(@$cookie, 0, 2);
467 7         9 my %hash;
468 7         13 while (@$cookie) {
469 29         33 my $k = shift @$cookie;
470 29         34 my $v = shift @$cookie;
471 29         53 $hash{$k} = $v;
472             }
473 7         13 my $version = delete $hash{version};
474 7         9 my $path = delete $hash{path};
475 7         8 my $domain = delete $hash{domain};
476 7         10 my $port = delete $hash{port};
477 7         15 my $expires = str2time(delete $hash{expires});
478              
479 7         203 my $path_spec = exists $hash{path_spec}; delete $hash{path_spec};
  7         8  
480 7         9 my $secure = exists $hash{secure}; delete $hash{secure};
  7         8  
481 7         8 my $discard = exists $hash{discard}; delete $hash{discard};
  7         8  
482              
483 7         18 my @array = ($version, $val, $port, $path_spec, $secure, $expires,
484             $discard);
485 7 100       12 push(@array, \%hash) if %hash;
486 7         48 $self->{COOKIES}{$domain}{$path}{$key} = \@array;
487             }
488             }
489 2         25 1;
490             }
491              
492              
493             sub revert
494             {
495 0     0 1 0 my $self = shift;
496 0         0 $self->clear->load;
497 0         0 $self;
498             }
499              
500              
501             sub clear
502             {
503 5     5 1 2018 my $self = shift;
504 5 50       17 if (@_ == 0) {
    0          
    0          
    0          
505 5         22 $self->{COOKIES} = {};
506             }
507             elsif (@_ == 1) {
508 0         0 delete $self->{COOKIES}{$_[0]};
509             }
510             elsif (@_ == 2) {
511 0         0 delete $self->{COOKIES}{$_[0]}{$_[1]};
512             }
513             elsif (@_ == 3) {
514 0         0 delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]};
515             }
516             else {
517 0         0 require Carp;
518 0         0 Carp::carp('Usage: $c->clear([domain [,path [,key]]])');
519             }
520 5         8 $self;
521             }
522              
523              
524             sub clear_temporary_cookies
525             {
526 2     2 1 115 my($self) = @_;
527              
528             $self->scan(sub {
529 6 100 66 6   21 if($_[9] or # "Discard" flag set
530             not $_[8]) { # No expire field?
531 3         4 $_[8] = -1; # Set the expire/max_age field
532 3         31 $self->set_cookie(@_); # Clear the cookie
533             }
534 2         10 });
535             }
536              
537              
538             sub DESTROY
539             {
540 27     27   1292 my $self = shift;
541 27         164 local($., $@, $!, $^E, $?);
542 27 50       425 $self->save if $self->{'autosave'};
543             }
544              
545              
546             sub scan
547             {
548 58     58 1 446 my($self, $cb) = @_;
549 58         75 my($domain,$path,$key);
550 58         68 for $domain (sort keys %{$self->{COOKIES}}) {
  58         210  
551 88         747 for $path (sort keys %{$self->{COOKIES}{$domain}}) {
  88         200  
552 108         469 for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) {
  108         220  
553             my($version,$val,$port,$path_spec,
554             $secure,$expires,$discard,$rest) =
555 129         600 @{$self->{COOKIES}{$domain}{$path}{$key}};
  129         273  
556 129 100       286 $rest = {} unless defined($rest);
557 129         210 &$cb($version,$key,$val,$path,$domain,$port,
558             $path_spec,$secure,$expires,$discard,$rest);
559             }
560             }
561             }
562             }
563              
564              
565             sub as_string
566             {
567 22     22 1 788 my($self, $skip_discard) = @_;
568 22         30 my @res;
569             $self->scan(sub {
570 48     48   118 my($version,$key,$val,$path,$domain,$port,
571             $path_spec,$secure,$expires,$discard,$rest) = @_;
572 48 50 66     103 return if $discard && $skip_discard;
573 48         82 my @h = ($key, $val);
574 48         65 push(@h, "path", $path);
575 48         70 push(@h, "domain" => $domain);
576 48 100       82 push(@h, "port" => $port) if defined $port;
577 48 100       94 push(@h, "path_spec" => undef) if $path_spec;
578 48 50       74 push(@h, "secure" => undef) if $secure;
579 48 100       81 push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires;
580 48 100       198 push(@h, "discard" => undef) if $discard;
581 48         47 my $k;
582 48         129 for $k (sort keys %$rest) {
583 3         10 push(@h, $k, $rest->{$k});
584             }
585 48         89 push(@h, "version" => $version);
586 48         100 push(@res, "Set-Cookie3: " . join_header_words(\@h));
587 22         128 });
588 22         1511 join("\n", @res, "");
589             }
590              
591             sub _host
592             {
593 129     129   224 my($request, $url) = @_;
594 129 100       259 if (my $h = $request->header("Host")) {
595 32         1158 $h =~ s/:\d+$//; # might have a port as well
596 32         91 return lc($h);
597             }
598 97         3384 return lc($url->host);
599             }
600              
601             sub _url_path
602             {
603 129     129   156 my $url = shift;
604 129         140 my $path;
605 129 50       351 if($url->can('epath')) {
606 0         0 $path = $url->epath; # URI::URL method
607             }
608             else {
609 129         249 $path = $url->path; # URI::_generic method
610             }
611 129 100       1148 $path = "/" unless length $path;
612 129         216 $path;
613             }
614              
615             sub _normalize_path # so that plain string compare can be used
616             {
617 6     6   9 my $x;
618 6         20 $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/
619 35         56 $x = uc($1);
620 35 100 100     126 $x eq "2F" || $x eq "25" ? "%$x" :
621             pack("C", hex($x));
622             /eg;
623 6         17 $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
  21         53  
624             }
625              
626             # deals with splitting values by ; and the fact that they could
627             # be in quotes which can also have escaping.
628             sub _split_text {
629 44     44   56 my $val = shift;
630 44         165 my @vals = grep { $_ ne q{} } split(/([;\\"])/, $val);
  214         356  
631 44         63 my @chunks;
632             # divide it up into chunks to be processed.
633 44         58 my $in_string = 0;
634 44         53 my @current_string;
635 44         94 for(my $i = 0; $i < @vals; $i++) {
636 203         243 my $chunk = $vals[$i];
637 203 100       258 if($in_string) {
638 18 100       30 if($chunk eq q{\\}) {
    100          
639             # don't care about next char probably.
640             # having said that, probably need to be appending to the chunks
641             # just dropping this.
642 2         3 $i++;
643 2 50       4 if($i < @vals) {
644 2         5 push @current_string, $vals[$i];
645             }
646             } elsif($chunk eq q{"}) {
647 4         8 $in_string = 0;
648             }
649             else {
650 12         19 push @current_string, $chunk;
651             }
652             } else {
653 185 100       272 if($chunk eq q{"}) {
    100          
654 4         14 $in_string = 1;
655             }
656             elsif($chunk eq q{;}) {
657 71         127 push @chunks, join(q{}, @current_string);
658 71         142 @current_string = ();
659             }
660             else {
661 110         213 push @current_string, $chunk;
662             }
663             }
664             }
665 44 100       99 push @chunks, join(q{}, @current_string) if @current_string;
666 44         183 s/^\s+// for @chunks;
667 44         122 return \@chunks;
668             }
669              
670             1;
671              
672             =pod
673              
674             =encoding UTF-8
675              
676             =head1 NAME
677              
678             HTTP::Cookies - HTTP cookie jars
679              
680             =head1 VERSION
681              
682             version 6.08
683              
684             =head1 SYNOPSIS
685              
686             use HTTP::Cookies;
687             $cookie_jar = HTTP::Cookies->new(
688             file => "$ENV{'HOME'}/lwp_cookies.dat",
689             autosave => 1,
690             );
691              
692             use LWP;
693             my $browser = LWP::UserAgent->new;
694             $browser->cookie_jar($cookie_jar);
695              
696             Or for an empty and temporary cookie jar:
697              
698             use LWP;
699             my $browser = LWP::UserAgent->new;
700             $browser->cookie_jar( {} );
701              
702             =head1 DESCRIPTION
703              
704             This class is for objects that represent a "cookie jar" -- that is, a
705             database of all the HTTP cookies that a given LWP::UserAgent object
706             knows about.
707              
708             Cookies are a general mechanism which server side connections can use
709             to both store and retrieve information on the client side of the
710             connection. For more information about cookies refer to
711             L and
712             L. This module also implements the
713             new style cookies described in L.
714             The two variants of cookies are supposed to be able to coexist happily.
715              
716             Instances of the class I are able to store a collection
717             of Set-Cookie2: and Set-Cookie: headers and are able to use this
718             information to initialize Cookie-headers in I objects.
719             The state of a I object can be saved in and restored from
720             files.
721              
722             =head1 LIMITATIONS
723              
724             This module does not support L<< Public Suffix|https://publicsuffix.org/
725             >> encouraged by a more recent standard, L<< RFC
726             6265|https://tools.ietf.org/html/rfc6265 >>.
727              
728             This module's shortcomings mean that a malicious Web site can set
729             cookies to track your user agent across all sites under a top level
730             domain. See F<< t/publicsuffix.t >> in this module's distribution for
731             details.
732              
733             L<< HTTP::CookieJar::LWP >> supports Public Suffix, but only provides a
734             limited subset of this module's functionality and L<< does not
735             support|HTTP::CookieJar/LIMITATIONS-AND-CAVEATS >> standards older than
736             I.
737              
738             =head1 METHODS
739              
740             The following methods are provided:
741              
742             =over 4
743              
744             =item $cookie_jar = HTTP::Cookies->new
745              
746             The constructor takes hash style parameters. The following
747             parameters are recognized:
748              
749             file: name of the file to restore cookies from and save cookies to
750             autosave: save during destruction (bool)
751             ignore_discard: save even cookies that are requested to be discarded (bool)
752             hide_cookie2: do not add Cookie2 header to requests
753              
754             Future parameters might include (not yet implemented):
755              
756             max_cookies 300
757             max_cookies_per_domain 20
758             max_cookie_size 4096
759              
760             no_cookies list of domain names that we never return cookies to
761              
762             =item $cookie_jar->get_cookies( $url_or_domain )
763              
764             =item $cookie_jar->get_cookies( $url_or_domain, $cookie_key,... )
765              
766             Returns a hash of the cookies that applies to the given URL. If a
767             domainname is given as argument, then a prefix of "https://" is assumed.
768              
769             If one or more $cookie_key parameters are provided return the given values,
770             or C if the cookie isn't available.
771              
772             =item $cookie_jar->add_cookie_header( $request )
773              
774             The add_cookie_header() method will set the appropriate Cookie:-header
775             for the I object given as argument. The $request must
776             have a valid url attribute before this method is called.
777              
778             =item $cookie_jar->extract_cookies( $response )
779              
780             The extract_cookies() method will look for Set-Cookie: and
781             Set-Cookie2: headers in the I object passed as
782             argument. Any of these headers that are found are used to update
783             the state of the $cookie_jar.
784              
785             =item $cookie_jar->set_cookie( $version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest )
786              
787             The set_cookie() method updates the state of the $cookie_jar. The
788             $key, $val, $domain, $port and $path arguments are strings. The
789             $path_spec, $secure, $discard arguments are boolean values. The $maxage
790             value is a number indicating number of seconds that this cookie will
791             live. A value of $maxage <= 0 will delete this cookie. The $version argument
792             sets the version of the cookie; the default value is 0 ( original Netscape
793             spec ). Setting $version to another value indicates the RFC to which the
794             cookie conforms (e.g. version 1 for RFC 2109). %rest defines various other
795             attributes like "Comment" and "CommentURL".
796              
797             =item $cookie_jar->save
798              
799             =item $cookie_jar->save( $file )
800              
801             =item $cookie_jar->save( file => $file, ignore_discard => $ignore_discard )
802              
803             This method file saves the state of the $cookie_jar to a file.
804             The state can then be restored later using the load() method. If a
805             filename is not specified we will use the name specified during
806             construction. If the $ignore_discard value is true (or not specified,
807             but attribute I was set at cookie jar construction),
808             then we will even save cookies that are marked to be discarded.
809              
810             The default is to save a sequence of "Set-Cookie3" lines.
811             "Set-Cookie3" is a proprietary LWP format, not known to be compatible
812             with any browser. The I sub-class can
813             be used to save in a format compatible with Netscape.
814              
815             =item $cookie_jar->load
816              
817             =item $cookie_jar->load( $file )
818              
819             This method reads the cookies from the file and adds them to the
820             $cookie_jar. The file must be in the format written by the save()
821             method.
822              
823             =item $cookie_jar->revert
824              
825             This method empties the $cookie_jar and re-loads the $cookie_jar
826             from the last save file.
827              
828             =item $cookie_jar->clear
829              
830             =item $cookie_jar->clear( $domain )
831              
832             =item $cookie_jar->clear( $domain, $path )
833              
834             =item $cookie_jar->clear( $domain, $path, $key )
835              
836             Invoking this method without arguments will empty the whole
837             $cookie_jar. If given a single argument only cookies belonging to
838             that domain will be removed. If given two arguments, cookies
839             belonging to the specified path within that domain are removed. If
840             given three arguments, then the cookie with the specified key, path
841             and domain is removed.
842              
843             =item $cookie_jar->clear_temporary_cookies
844              
845             Discard all temporary cookies. Scans for all cookies in the jar
846             with either no expire field or a true C flag. To be
847             called when the user agent shuts down according to RFC 2965.
848              
849             =item $cookie_jar->scan( \&callback )
850              
851             The argument is a subroutine that will be invoked for each cookie
852             stored in the $cookie_jar. The subroutine will be invoked with
853             the following arguments:
854              
855             0 version
856             1 key
857             2 val
858             3 path
859             4 domain
860             5 port
861             6 path_spec
862             7 secure
863             8 expires
864             9 discard
865             10 hash
866              
867             =item $cookie_jar->as_string
868              
869             =item $cookie_jar->as_string( $skip_discardables )
870              
871             The as_string() method will return the state of the $cookie_jar
872             represented as a sequence of "Set-Cookie3" header lines separated by
873             "\n". If $skip_discardables is TRUE, it will not return lines for
874             cookies with the I attribute.
875              
876             =back
877              
878             =head1 SEE ALSO
879              
880             L, L
881              
882             =head1 AUTHOR
883              
884             Gisle Aas
885              
886             =head1 COPYRIGHT AND LICENSE
887              
888             This software is copyright (c) 2002-2019 by Gisle Aas.
889              
890             This is free software; you can redistribute it and/or modify it under
891             the same terms as the Perl 5 programming language system itself.
892              
893             =cut
894              
895             __END__