# The old Netscape cookie format for Set-Cookie
# http://wp.netscape.com/newsref/std/cookie_spec.html
# can for instance contain an unquoted "," in the expires
# field, so we have to use this ad-hoc parser.
my $now = time();
# Build a hash of cookies that was present in Set-Cookie2
# headers. We need to skip them if we also find them in a
# Set-Cookie header.
my %in_set2;
for (@set) {
$in_set2{$_->[0]}++;
}
my $set;
for $set (@ns_set) {
$set =~ s/^\s+//;
my @cur;
my $param;
my $expires;
my $first_param = 1;
for $param (split(/;\s*/, $set)) {
next unless length($param);
my($k,$v) = split(/\s*=\s*/, $param, 2);
if (defined $v) {
$v =~ s/\s+$//;
#print "$k => $v\n";
}
else {
$k =~ s/\s+$//;
#print "$k => undef";
}
if (!$first_param && lc($k) eq "expires") {
my $etime = str2time($v);
if ($etime) {
push(@cur, "Max-Age" => str2time($v) - $now);
$expires++;
}
}
elsif (!$first_param && lc($k) =~ /^(?:version|discard|ns-cookie)/) {
# ignore
}
else {
push(@cur, $k => $v);
}
$first_param = 0;
}
next unless @cur;
next if $in_set2{$cur[0]};
# push(@cur, "Port" => $req_port);
push(@cur, "Discard" => undef) unless $expires;
push(@cur, "Version" => 0);
push(@cur, "ns-cookie" => 1);
push(@set, \@cur);
}
}
SET_COOKIE:
for my $set (@set) {
next unless @$set >= 2;
my $key = shift @$set;
my $val = shift @$set;
LWP::Debug::debug("Set cookie $key => $val");
my %hash;
while (@$set) {
my $k = shift @$set;
my $v = shift @$set;
my $lc = lc($k);
# don't loose case distinction for unknown fields
$k = $lc if $lc =~ /^(?:discard|domain|max-age|
path|port|secure|version)$/x;
if ($k eq "discard" || $k eq "secure") {
$v = 1 unless defined $v;
}
next if exists $hash{$k}; # only first value is signigicant
$hash{$k} = $v;
};
my %orig_hash = %hash;
my $version = delete $hash{version};
$version = 1 unless defined($version);
my $discard = delete $hash{discard};
my $secure = delete $hash{secure};
my $maxage = delete $hash{'max-age'};
my $ns_cookie = delete $hash{'ns-cookie'};
# Check domain
my $domain = delete $hash{domain};
$domain = lc($domain) if defined $domain;
if (defined($domain)
&& $domain ne $req_host && $domain ne ".$req_host") {
if ($domain !~ /\./ && $domain ne "local") {
LWP::Debug::debug("Domain $domain contains no dot");
next SET_COOKIE;
}
$domain = ".$domain" unless $domain =~ /^\./;
=3= |