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