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