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__ |