File Coverage

blib/lib/Mojo/UserAgent/CookieJar.pm
Criterion Covered Total %
statement 72 72 100.0
branch 38 38 100.0
condition 27 29 93.1
subroutine 12 12 100.0
pod 6 6 100.0
total 155 157 98.7


line stmt bran cond sub pod time code
1             package Mojo::UserAgent::CookieJar;
2 54     54   915 use Mojo::Base -base;
  54         153  
  54         413  
3              
4 54     54   18696 use Mojo::Cookie::Request;
  54         177  
  54         616  
5 54     54   17352 use Mojo::Path;
  54         192  
  54         398  
6 54     54   399 use Scalar::Util qw(looks_like_number);
  54         121  
  54         71848  
7              
8             has 'ignore';
9             has max_cookie_size => 4096;
10              
11             sub add {
12 132     132 1 337 my ($self, @cookies) = @_;
13              
14 132         383 my $size = $self->max_cookie_size;
15 132         343 for my $cookie (@cookies) {
16              
17             # Convert max age to expires
18 139         368 my $age = $cookie->max_age;
19 139 100       566 $cookie->expires($age <= 0 ? 0 : $age + time) if looks_like_number $age;
    100          
20              
21             # Check cookie size
22 139 100 100     423 next if length($cookie->value // '') > $size;
23              
24             # Replace cookie
25 138 100 100     426 next unless my $domain = lc($cookie->domain // '');
26 137 100       329 next unless my $path = $cookie->path;
27 135 100 100     334 next unless length(my $name = $cookie->name // '');
28 134   100     527 my $jar = $self->{jar}{$domain} //= [];
29 134         372 @$jar = (grep({ _compare($_, $path, $name, $domain) } @$jar), $cookie);
  453         870  
30             }
31              
32 132         412 return $self;
33             }
34              
35             sub all {
36 14     14 1 37 my $jar = shift->{jar};
37 14         66 return [map { @{$jar->{$_}} } sort keys %$jar];
  10         15  
  10         65  
38             }
39              
40             sub collect {
41 953     953 1 2386 my ($self, $tx) = @_;
42              
43 953         2521 my $url = $tx->req->url;
44 953         1847 for my $cookie (@{$tx->res->cookies}) {
  953         2310  
45              
46             # Validate domain
47 138         517 my $host = lc $url->ihost;
48 138 100       413 $cookie->domain($host)->host_only(1) unless $cookie->domain;
49 138         322 my $domain = lc $cookie->domain;
50 138 100       409 if (my $cb = $self->ignore) { next if $cb->($cookie) }
  50 100       139  
51 129 100 100     627 next if $host ne $domain && ($host !~ /\Q.$domain\E$/ || $host =~ /\.\d+$/);
      100        
52              
53             # Validate path
54 122   66     291 my $path = $cookie->path // $url->path->to_dir->to_abs_string;
55 122         488 $path = Mojo::Path->new($path)->trailing_slash(0)->to_abs_string;
56 122 100       604 next unless _path($path, $url->path->to_abs_string);
57 119         435 $self->add($cookie->path($path));
58             }
59             }
60              
61 7     7 1 52 sub empty { delete shift->{jar} }
62              
63             sub find {
64 246     246 1 605 my ($self, $url) = @_;
65              
66 246         492 my @found;
67 246         645 my $domain = my $host = lc $url->ihost;
68 246         4971 my $path = $url->path->to_abs_string;
69 246         991 while ($domain) {
70 926 100       2648 next unless my $old = $self->{jar}{$domain};
71              
72             # Grab cookies
73 249         744 my $new = $self->{jar}{$domain} = [];
74 249         692 for my $cookie (@$old) {
75 550 100 100     1582 next if $cookie->host_only && $host ne $cookie->domain;
76              
77             # Check if cookie has expired
78 549 100       1411 if (defined(my $expires = $cookie->expires)) { next if time > $expires }
  323 100       886  
79 545         1161 push @$new, $cookie;
80              
81             # Taste cookie
82 545 100 100     1233 next if $cookie->secure && $url->protocol ne 'https';
83 544 100       1304 next unless _path($cookie->path, $path);
84 410         1197 my $name = $cookie->name;
85 410         1059 my $value = $cookie->value;
86 410         1601 push @found, Mojo::Cookie::Request->new(name => $name, value => $value);
87             }
88             }
89              
90             # Remove another part
91 926         3264 continue { $domain =~ s/^[^.]*\.*// }
92              
93 246         1528 return \@found;
94             }
95              
96             sub prepare {
97 959     959 1 2471 my ($self, $tx) = @_;
98 959 100       1775 return unless keys %{$self->{jar}};
  959         4543  
99 225         695 my $req = $tx->req;
100 225         453 $req->cookies(@{$self->find($req->url)});
  225         565  
101             }
102              
103             sub _compare {
104 453     453   864 my ($cookie, $path, $name, $domain) = @_;
105 453   66     889 return $cookie->path ne $path || $cookie->name ne $name || $cookie->domain ne $domain;
106             }
107              
108 666 100 100 666   3189 sub _path { $_[0] eq '/' || $_[0] eq $_[1] || index($_[1], "$_[0]/") == 0 }
109              
110             1;
111              
112             =encoding utf8
113              
114             =head1 NAME
115              
116             Mojo::UserAgent::CookieJar - Cookie jar for HTTP user agents
117              
118             =head1 SYNOPSIS
119              
120             use Mojo::UserAgent::CookieJar;
121              
122             # Add response cookies
123             my $jar = Mojo::UserAgent::CookieJar->new;
124             $jar->add(
125             Mojo::Cookie::Response->new(
126             name => 'foo',
127             value => 'bar',
128             domain => 'localhost',
129             path => '/test'
130             )
131             );
132              
133             # Find request cookies
134             for my $cookie (@{$jar->find(Mojo::URL->new('http://localhost/test'))}) {
135             say $cookie->name;
136             say $cookie->value;
137             }
138              
139             =head1 DESCRIPTION
140              
141             L is a minimalistic and relaxed cookie jar used by L, based on L
142             6265|https://tools.ietf.org/html/rfc6265>.
143              
144             =head1 ATTRIBUTES
145              
146             L implements the following attributes.
147              
148             =head2 ignore
149              
150             my $ignore = $jar->ignore;
151             $jar = $jar->ignore(sub {...});
152              
153             A callback used to decide if a cookie should be ignored by L.
154              
155             # Ignore all cookies
156             $jar->ignore(sub { 1 });
157              
158             # Ignore cookies for domains "com", "net" and "org"
159             $jar->ignore(sub ($cookie) {
160             return undef unless my $domain = $cookie->domain;
161             return $domain eq 'com' || $domain eq 'net' || $domain eq 'org';
162             });
163              
164             =head2 max_cookie_size
165              
166             my $size = $jar->max_cookie_size;
167             $jar = $jar->max_cookie_size(4096);
168              
169             Maximum cookie size in bytes, defaults to C<4096> (4KiB).
170              
171             =head1 METHODS
172              
173             L inherits all methods from L and implements the following new ones.
174              
175             =head2 add
176              
177             $jar = $jar->add(@cookies);
178              
179             Add multiple L objects to the jar.
180              
181             =head2 all
182              
183             my $cookies = $jar->all;
184              
185             Return all L objects that are currently stored in the jar.
186              
187             # Names of all cookies
188             say $_->name for @{$jar->all};
189              
190             =head2 collect
191              
192             $jar->collect(Mojo::Transaction::HTTP->new);
193              
194             Collect response cookies from transaction.
195              
196             =head2 empty
197              
198             $jar->empty;
199              
200             Empty the jar.
201              
202             =head2 find
203              
204             my $cookies = $jar->find(Mojo::URL->new);
205              
206             Find L objects in the jar for L object.
207              
208             # Names of all cookies found
209             say $_->name for @{$jar->find(Mojo::URL->new('http://example.com/foo'))};
210              
211             =head2 prepare
212              
213             $jar->prepare(Mojo::Transaction::HTTP->new);
214              
215             Prepare request cookies for transaction.
216              
217             =head1 SEE ALSO
218              
219             L, L, L.
220              
221             =cut