package HTTP::Cookies;
use strict;
use HTTP::Date qw(str2time time2str);
use HTTP::Headers::Util qw(_split_header_words join_header_words);
use LWP::Debug ();
use vars qw($VERSION $EPOCH_OFFSET);
$VERSION = "5.817";
# Legacy: because "use "HTTP::Cookies" used be the ONLY way
# to load the class HTTP::Cookies::Netscape.
require HTTP::Cookies::Netscape;
$EPOCH_OFFSET = 0; # difference from Unix epoch
if ($^O eq "MacOS") {
require Time::Local;
$EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70);
}
# A HTTP::Cookies object is a hash. The main attribute is the
# COOKIES 3 level hash: $self->{COOKIES}{$domain}{$path}{$key}.
sub new
{
my $class = shift;
my $self = bless {
COOKIES => {},
}, $class;
my %cnf = @_;
for (keys %cnf) {
$self->{lc($_)} = $cnf{$_};
}
$self->load;
$self;
}
sub add_cookie_header
{
my $self = shift;
my $request = shift || return;
my $url = $request->url;
my $scheme = $url->scheme;
unless ($scheme =~ /^https?\z/) {
LWP::Debug::debug("Will not add cookies to non-HTTP requests");
return;
}
my $domain = _host($request, $url);
$domain = "$domain.local" unless $domain =~ /\./;
my $secure_request = ($scheme eq "https");
my $req_path = _url_path($url);
my $req_port = $url->port;
my $now = time();
_normalize_path($req_path) if $req_path =~ /%/;
my @cval; # cookie values for the "Cookie" header
my $set_ver;
my $netscape_only = 0; # An exact domain match applies to any cookie
while ($domain =~ /\./) {
LWP::Debug::debug("Checking $domain for cookies");
my $cookies = $self->{COOKIES}{$domain};
next unless $cookies;
if ($self->{delayload} && defined($cookies->{'//+delayload'})) {
my $cookie_data = $cookies->{'//+delayload'}{'cookie'};
delete $self->{COOKIES}{$domain};
$self->load_cookie($cookie_data->[1]);
$cookies = $self->{COOKIES}{$domain};
next unless $cookies; # should not really happen
}
# Want to add cookies corresponding to the most specific paths
# first (i.e. longest path first)
my $path;
for $path (sort {length($b) <=> length($a) } keys %$cookies) {
LWP::Debug::debug("- checking cookie path=$path");
if (index($req_path, $path) != 0) {
LWP::Debug::debug(" path $path:$req_path does not fit");
next;
}
my($key,$array);
while (($key,$array) = each %{$cookies->{$path}}) {
my($version,$val,$port,$path_spec,$secure,$expires) = @$array;
LWP::Debug::debug(" - checking cookie $key=$val");
if ($secure && !$secure_request) {
LWP::Debug::debug(" not a secure requests");
next;
}
if ($expires && $expires < $now) {
LWP::Debug::debug(" expired");
next;
}
if ($port) {
my $found;
if ($port =~ s/^_//) {
# The correponding Set-Cookie attribute was empty
=1= |