From cb583b36192f8f3eb4c780f67571fe0b5de61f82 Mon Sep 17 00:00:00 2001 From: Olaf Alders Date: Tue, 23 Jun 2026 20:29:02 +0000 Subject: [PATCH 1/7] precious: add canonical config Co-Authored-By: Claude Opus 4.8 --- dist.ini | 3 +++ precious.toml | 23 +++++++++++++++++++++++ 2 files changed, 26 insertions(+) create mode 100644 precious.toml diff --git a/dist.ini b/dist.ini index 6617c705..86ae05e7 100644 --- a/dist.ini +++ b/dist.ini @@ -37,3 +37,6 @@ Test::Pod::Coverage::Configurable.skip = HTTP::Cookies::Microsoft Test::Pod::Coverage::Configurable.trustme = HTTP::Cookies => qr/set_cookie_ok/ [BumpVersionAfterRelease] + +[PruneFiles] +filename = precious.toml diff --git a/precious.toml b/precious.toml new file mode 100644 index 00000000..5aa89789 --- /dev/null +++ b/precious.toml @@ -0,0 +1,23 @@ +[commands.perltidy] +type = "both" +include = ["**/*.{pl,pm,t,psgi}"] +cmd = ["perltidy", "--profile=$PRECIOUS_ROOT/.perltidyrc"] +lint-flags = ["--assert-tidy", "--no-standard-output", "--outfile=/dev/null"] +tidy-flags = ["--backup-and-modify-in-place", "--backup-file-extension=/"] +ok-exit-codes = [0] +lint-failure-exit-codes = [2] + +[commands.perlvars] +type = "lint" +include = ["**/*.pm"] +cmd = ["perlvars"] +ok-exit-codes = [0] +lint-failure-exit-codes = [1] + +[commands.omegasort-gitignore] +type = "both" +include = [".gitignore"] +cmd = ["omegasort", "--sort", "path", "--unique"] +lint-flags = ["--check"] +ok-exit-codes = [0] +lint-failure-exit-codes = [1] From 49a585fb6e94861ca2ca2bfac767c4ad37d507d7 Mon Sep 17 00:00:00 2001 From: Olaf Alders Date: Tue, 23 Jun 2026 20:29:50 +0000 Subject: [PATCH 2/7] perltidy: consolidate profile to .perltidyrc and drop -b Co-Authored-By: Claude Opus 4.8 --- perltidyrc => .perltidyrc | 1 - dist.ini | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) rename perltidyrc => .perltidyrc (98%) diff --git a/perltidyrc b/.perltidyrc similarity index 98% rename from perltidyrc rename to .perltidyrc index b7ed6247..3779688b 100644 --- a/perltidyrc +++ b/.perltidyrc @@ -1,7 +1,6 @@ --blank-lines-before-packages=0 --iterations=2 --no-outdent-long-comments --b -bar -boc -ci=4 diff --git a/dist.ini b/dist.ini index 86ae05e7..891005ca 100644 --- a/dist.ini +++ b/dist.ini @@ -40,3 +40,4 @@ Test::Pod::Coverage::Configurable.trustme = HTTP::Cookies => qr/set_cookie_ok/ [PruneFiles] filename = precious.toml +filename = .perltidyrc From 48f8176462e86885be62018fcbecae215f44dc51 Mon Sep 17 00:00:00 2001 From: Olaf Alders Date: Tue, 23 Jun 2026 20:30:05 +0000 Subject: [PATCH 3/7] tidyall: delete config files and ignore entries Co-Authored-By: Claude Opus 4.8 --- .gitignore | 1 - 1 file changed, 1 deletion(-) diff --git a/.gitignore b/.gitignore index 6392fa9e..ae09de4e 100644 --- a/.gitignore +++ b/.gitignore @@ -8,5 +8,4 @@ pm_to_blib t/CAN_TALK_TO_OURSELF *.tar.gz t/live/ENABLED -tidyall.ini xx* From 8a0754cead40a562cfe55db5f0cf95bfb53a6e50 Mon Sep 17 00:00:00 2001 From: Olaf Alders Date: Tue, 23 Jun 2026 20:31:05 +0000 Subject: [PATCH 4/7] dist.ini: add App::perlvars develop prereq for precious Co-Authored-By: Claude Opus 4.8 --- cpanfile | 3 ++- dist.ini | 3 +++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/cpanfile b/cpanfile index 06abbebb..649d0d83 100644 --- a/cpanfile +++ b/cpanfile @@ -1,4 +1,4 @@ -# This file is generated by Dist::Zilla::Plugin::CPANFile v6.031 +# This file is generated by Dist::Zilla::Plugin::CPANFile v6.037 # Do not edit this file directly. To change prereqs, edit the `dist.ini` file. requires "Carp" => "0"; @@ -27,6 +27,7 @@ on 'configure' => sub { }; on 'develop' => sub { + requires "App::perlvars" => "0"; requires "Pod::Coverage::TrustPod" => "0"; requires "Test::CPAN::Changes" => "0.19"; requires "Test::EOL" => "0"; diff --git a/dist.ini b/dist.ini index 891005ca..b56fbaf7 100644 --- a/dist.ini +++ b/dist.ini @@ -38,6 +38,9 @@ Test::Pod::Coverage::Configurable.trustme = HTTP::Cookies => qr/set_cookie_ok/ [BumpVersionAfterRelease] +[Prereqs / DevelopRequires] +App::perlvars = 0 + [PruneFiles] filename = precious.toml filename = .perltidyrc From 06c5d93e5cb6f322356e29c6554cfa7bf457ac22 Mon Sep 17 00:00:00 2001 From: Olaf Alders Date: Tue, 23 Jun 2026 20:31:44 +0000 Subject: [PATCH 5/7] ci: add precious lint job Co-Authored-By: Claude Opus 4.8 --- .github/workflows/lint.yml | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 .github/workflows/lint.yml diff --git a/.github/workflows/lint.yml b/.github/workflows/lint.yml new file mode 100644 index 00000000..7769b2ab --- /dev/null +++ b/.github/workflows/lint.yml @@ -0,0 +1,34 @@ +name: lint + +on: + push: + branches: + - master + pull_request: + workflow_dispatch: + +concurrency: + group: ${{ github.workflow }}-${{ github.ref }} + cancel-in-progress: true + +jobs: + precious: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v7 + - uses: shogo82148/actions-setup-perl@v1 + with: + perl-version: "5.42" + - uses: oalders/install-ubi-action@v0.0.6 + with: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + projects: | + houseabsolute/precious + houseabsolute/omegasort + - uses: perl-actions/install-with-cpm@v2 + with: + install: | + App::perlvars + Perl::Tidy + sudo: false + - run: precious lint --all From 8120dae572cb41ff5b64d69b323b104d9f6cb4f3 Mon Sep 17 00:00:00 2001 From: Olaf Alders Date: Tue, 23 Jun 2026 20:32:32 +0000 Subject: [PATCH 6/7] hooks: add scripts/pre-commit for precious lint Contributors run `scripts/pre-commit --init` once per clone to install the hook. It runs `precious lint --staged` and blocks direct commits to the master branch. Co-Authored-By: Claude Opus 4.8 --- dist.ini | 1 + scripts/pre-commit | 57 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 58 insertions(+) create mode 100755 scripts/pre-commit diff --git a/dist.ini b/dist.ini index b56fbaf7..7bf2cec0 100644 --- a/dist.ini +++ b/dist.ini @@ -44,3 +44,4 @@ App::perlvars = 0 [PruneFiles] filename = precious.toml filename = .perltidyrc +filename = scripts/pre-commit diff --git a/scripts/pre-commit b/scripts/pre-commit new file mode 100755 index 00000000..ad086f7c --- /dev/null +++ b/scripts/pre-commit @@ -0,0 +1,57 @@ +#!/bin/sh +# Pre-commit hook: enforce `precious lint` on staged files and +# block direct commits to the default branch. +# +# Install (run once per clone): +# scripts/pre-commit --init + +set -eu + +if [ "${1:-}" = "--init" ]; then + repo_root=$(git rev-parse --show-toplevel) + # Resolve the hooks dir via git so it works in plain repos, linked + # worktrees (where `.git` is a file pointing into the common git dir), + # and setups that override `core.hooksPath`. Run with `-C "$repo_root"` + # so the output is anchored under the worktree root regardless of + # which subdirectory the contributor invoked `--init` from. + hooks_dir=$(git -C "$repo_root" rev-parse --git-path hooks) + case "$hooks_dir" in + /*) ;; + *) hooks_dir="$repo_root/$hooks_dir" ;; + esac + hook_path="$hooks_dir/pre-commit" + target="$repo_root/scripts/pre-commit" + if [ -e "$hook_path" ] && [ ! -L "$hook_path" ]; then + echo "ERROR: $hook_path exists and is not a symlink." >&2 + echo "Move or remove it, then re-run scripts/pre-commit --init." >&2 + exit 1 + fi + chmod +x "$target" + ln -sf "$target" "$hook_path" + echo "Installed pre-commit hook: $hook_path -> $target" + exit 0 +fi + +# Anchor to the working-tree root before doing anything else. Git exports +# GIT_DIR into the hook environment, so `--show-toplevel` resolves the right +# tree even when a wrapper invokes `git commit` from a directory outside (or +# beside) the repo. Without this, `precious lint --staged` runs from that +# foreign cwd, fails to find precious.toml, and the hook breaks. +cd "$(git rev-parse --show-toplevel)" + +# Block direct commits to the default branch. +default_branch="master" +branch=$(git symbolic-ref --short HEAD 2>/dev/null || true) +if [ "$branch" = "$default_branch" ]; then + echo "ERROR: Direct commits to '$default_branch' branch are not allowed." >&2 + echo "Please create a feature branch instead:" >&2 + echo " git checkout -b feature/your-feature-name" >&2 + exit 1 +fi + +# Run precious lint on staged files +if ! precious lint -q --staged; then + echo "pre-commit hook failed: precious lint found issues with staged files" >&2 + echo "Please run 'precious tidy -q --staged' and try again" >&2 + exit 1 +fi From d94f18ea4f18066f1ca15f0c70d67fa6eaeff0f2 Mon Sep 17 00:00:00 2001 From: Olaf Alders Date: Thu, 25 Jun 2026 15:15:32 +0000 Subject: [PATCH 7/7] perltidy --- lib/HTTP/Cookies.pm | 917 +++++++++++++++++----------------- lib/HTTP/Cookies/Microsoft.pm | 274 +++++----- lib/HTTP/Cookies/Netscape.pm | 59 ++- t/10-original_spec.t | 124 +++-- t/11-rfc_2965.t | 108 ++-- t/cookies.t | 558 ++++++++++++--------- t/issue26.t | 16 +- t/issue32.t | 26 +- t/publicsuffix.t | 20 +- 9 files changed, 1168 insertions(+), 934 deletions(-) diff --git a/lib/HTTP/Cookies.pm b/lib/HTTP/Cookies.pm index 09db1d3c..7059afa9 100644 --- a/lib/HTTP/Cookies.pm +++ b/lib/HTTP/Cookies.pm @@ -1,7 +1,7 @@ package HTTP::Cookies; use strict; -use HTTP::Date qw(str2time parse_date time2str); +use HTTP::Date qw(str2time parse_date time2str); use HTTP::Headers::Util qw(_split_header_words join_header_words); our $EPOCH_OFFSET; @@ -11,413 +11,430 @@ our $VERSION = '6.12'; # to load the class HTTP::Cookies::Netscape. require HTTP::Cookies::Netscape; -$EPOCH_OFFSET = 0; # difference from Unix epoch +$EPOCH_OFFSET = 0; # difference from Unix epoch # A HTTP::Cookies object is a hash. The main attribute is the # COOKIES 3 level hash: $self->{COOKIES}{$domain}{$path}{$key}. -sub new -{ +sub new { my $class = shift; - my $self = bless { - COOKIES => {}, + my $self = bless { + COOKIES => {}, }, $class; my %cnf = @_; - for (keys %cnf) { - $self->{lc($_)} = $cnf{$_}; + for ( keys %cnf ) { + $self->{ lc($_) } = $cnf{$_}; } $self->load; $self; } - -sub add_cookie_header -{ - my $self = shift; +sub add_cookie_header { + my $self = shift; my $request = shift || return; - my $url = $request->uri; - my $scheme = $url->scheme; - unless ($scheme =~ /^https?\z/) { - return; + my $url = $request->uri; + my $scheme = $url->scheme; + unless ( $scheme =~ /^https?\z/ ) { + return; } - my $domain = _host($request, $url); + 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(); + 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 @cval; # cookie values for the "Cookie" header my $set_ver; - my $netscape_only = 0; # An exact domain match applies to any cookie + my $netscape_only = 0; # An exact domain match applies to any cookie + + while ( $domain =~ /\./ ) { - while ($domain =~ /\./) { # 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) { - if (index($req_path, $path) != 0) { - next; - } - - my($key,$array); - while (($key,$array) = each %{$cookies->{$path}}) { - my($version,$val,$port,$path_spec,$secure,$expires) = @$array; - if ($secure && !$secure_request) { - next; - } - if ($expires && $expires < $now) { - next; - } - if ($port) { - my $found; - if ($port =~ s/^_//) { - # The corresponding Set-Cookie attribute was empty - $found++ if $port eq $req_port; - $port = ""; - } - else { - my $p; - for $p (split(/,/, $port)) { - $found++, last if $p eq $req_port; - } - } - unless ($found) { - next; - } - } - if ($version > 0 && $netscape_only) { - next; - } - - # set version number of cookie header. - # XXX: What should it be if multiple matching + 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 ) { + if ( index( $req_path, $path ) != 0 ) { + next; + } + + my ( $key, $array ); + while ( ( $key, $array ) = each %{ $cookies->{$path} } ) { + my ( $version, $val, $port, $path_spec, $secure, $expires ) + = @$array; + if ( $secure && !$secure_request ) { + next; + } + if ( $expires && $expires < $now ) { + next; + } + if ($port) { + my $found; + if ( $port =~ s/^_// ) { + + # The corresponding Set-Cookie attribute was empty + $found++ if $port eq $req_port; + $port = ""; + } + else { + my $p; + for $p ( split( /,/, $port ) ) { + $found++, last if $p eq $req_port; + } + } + unless ($found) { + next; + } + } + if ( $version > 0 && $netscape_only ) { + next; + } + + # set version number of cookie header. + # XXX: What should it be if multiple matching # Set-Cookie headers have different versions themselves - if (!$set_ver++) { - if ($version >= 1) { - push(@cval, "\$Version=$version"); - } - elsif (!$self->{hide_cookie2}) { - $request->header(Cookie2 => '$Version="1"'); - } - } - - # do we need to quote the value - if ($val =~ /\W/ && $version) { - $val =~ s/([\\\"])/\\$1/g; - $val = qq("$val"); - } - - # and finally remember this cookie - push(@cval, "$key=$val"); - if ($version >= 1) { - push(@cval, qq(\$Path="$path")) if $path_spec; - push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./; - if (defined $port) { - my $p = '$Port'; - $p .= qq(="$port") if length $port; - push(@cval, $p); - } - } - - } + if ( !$set_ver++ ) { + if ( $version >= 1 ) { + push( @cval, "\$Version=$version" ); + } + elsif ( !$self->{hide_cookie2} ) { + $request->header( Cookie2 => '$Version="1"' ); + } + } + + # do we need to quote the value + if ( $val =~ /\W/ && $version ) { + $val =~ s/([\\\"])/\\$1/g; + $val = qq("$val"); + } + + # and finally remember this cookie + push( @cval, "$key=$val" ); + if ( $version >= 1 ) { + push( @cval, qq(\$Path="$path") ) if $path_spec; + push( @cval, qq(\$Domain="$domain") ) if $domain =~ /^\./; + if ( defined $port ) { + my $p = '$Port'; + $p .= qq(="$port") if length $port; + push( @cval, $p ); + } + } + + } } - } continue { - # Try with a more general domain, alternately stripping - # leading name components and leading dots. When this - # results in a domain with no leading dot, it is for - # Netscape cookie compatibility only: - # - # a.b.c.net Any cookie - # .b.c.net Any cookie - # b.c.net Netscape cookie only - # .c.net Any cookie - - if ($domain =~ s/^\.+//) { - $netscape_only = 1; - } - else { - $domain =~ s/[^.]*//; - $netscape_only = 0; - } + } + continue { + # Try with a more general domain, alternately stripping + # leading name components and leading dots. When this + # results in a domain with no leading dot, it is for + # Netscape cookie compatibility only: + # + # a.b.c.net Any cookie + # .b.c.net Any cookie + # b.c.net Netscape cookie only + # .c.net Any cookie + + if ( $domain =~ s/^\.+// ) { + $netscape_only = 1; + } + else { + $domain =~ s/[^.]*//; + $netscape_only = 0; + } } if (@cval) { - if (my $old = $request->header("Cookie")) { - unshift(@cval, $old); - } - $request->header(Cookie => join("; ", @cval)); - if (my $hash = $request->{_http_cookies}) { - %$hash = (map split(/=/, $_, 2), @cval); - } + if ( my $old = $request->header("Cookie") ) { + unshift( @cval, $old ); + } + $request->header( Cookie => join( "; ", @cval ) ); + if ( my $hash = $request->{_http_cookies} ) { + %$hash = ( map split( /=/, $_, 2 ), @cval ); + } } $request; } - -sub get_cookies -{ +sub get_cookies { my $self = shift; - my $url = shift; + my $url = shift; $url = "https://$url" unless $url =~ m,^[a-zA-Z][a-zA-Z0-9.+\-]*:,; require HTTP::Request; - my $req = HTTP::Request->new(GET => $url); + my $req = HTTP::Request->new( GET => $url ); my $cookies = $req->{_http_cookies} = {}; $self->add_cookie_header($req); if (@_) { - return map $cookies->{$_}, @_ if wantarray; - return $cookies->{$_[0]}; + return map $cookies->{$_}, @_ if wantarray; + return $cookies->{ $_[0] }; } return $cookies; } - -sub extract_cookies -{ - my $self = shift; +sub extract_cookies { + my $self = shift; my $response = shift || return; - my @set = _split_header_words($response->_header("Set-Cookie2")); + my @set = _split_header_words( $response->_header("Set-Cookie2") ); my @ns_set = $response->_header("Set-Cookie"); - return $response unless @set || @ns_set; # quick exit + return $response unless @set || @ns_set; # quick exit - my $request = $response->request; - my $url = $request->uri; - my $req_host = _host($request, $url); + my $request = $response->request; + my $url = $request->uri; + my $req_host = _host( $request, $url ); $req_host = "$req_host.local" unless $req_host =~ /\./; my $req_port = $url->port; my $req_path = _url_path($url); _normalize_path($req_path) if $req_path =~ /%/; if (@ns_set) { - # The old Netscape cookie format for Set-Cookie - # http://curl.haxx.se/rfc/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) { + + # The old Netscape cookie format for Set-Cookie + # http://curl.haxx.se/rfc/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_text($set)}) { + my @cur; + my $param; + my $expires; + my $first_param = 1; + for $param ( @{ _split_text($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 (defined $etime) { - push(@cur, "Max-Age" => $etime - $now); - $expires++; - } - else { - # parse_date can deal with years outside the range of time_t, - my($year, $mon, $day, $hour, $min, $sec, $tz) = parse_date($v); - if ($year) { - my $thisyear = (gmtime)[5] + 1900; - if ($year < $thisyear) { - push(@cur, "Max-Age" => -1); # any negative value will do - $expires++; - } - elsif ($year >= $thisyear + 10) { - # the date is at least 10 years into the future, just replace - # it with something approximate - push(@cur, "Max-Age" => 10 * 365 * 24 * 60 * 60); - $expires++; - } - } - } - } - elsif (!$first_param && lc($k) eq 'max-age') { + 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 ( defined $etime ) { + push( @cur, "Max-Age" => $etime - $now ); + $expires++; + } + else { + # parse_date can deal with years outside the range of time_t, + my ( $year, $mon, $day, $hour, $min, $sec, $tz ) + = parse_date($v); + if ($year) { + my $thisyear = (gmtime)[5] + 1900; + if ( $year < $thisyear ) { + push( @cur, "Max-Age" => -1 ) + ; # any negative value will do + $expires++; + } + elsif ( $year >= $thisyear + 10 ) { + + # the date is at least 10 years into the future, just replace + # it with something approximate + push( + @cur, + "Max-Age" => 10 * 365 * 24 * 60 * 60 + ); + $expires++; + } + } + } + } + elsif ( !$first_param && lc($k) eq 'max-age' ) { $expires++; } - elsif (!$first_param && lc($k) =~ /^(?:version|discard|ns-cookie)/) { + elsif ( !$first_param + && lc($k) =~ /^(?:version|discard|ns-cookie)/ ) { + # ignore } - else { - push(@cur, $k => $v); - } - $first_param = 0; - } + 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); - } + 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: +SET_COOKIE: for my $set (@set) { - next unless @$set >= 2; - - my $key = shift @$set; - my $val = shift @$set; - - 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| + next unless @$set >= 2; + + my $key = shift @$set; + my $val = shift @$set; + + 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 significant - $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") { - next SET_COOKIE; - } - $domain = ".$domain" unless $domain =~ /^\./; - if ($domain =~ /\.\d+$/) { - next SET_COOKIE; - } - my $len = length($domain); - unless (substr($req_host, -$len) eq $domain) { - next SET_COOKIE; - } - my $hostpre = substr($req_host, 0, length($req_host) - $len); - if ($hostpre =~ /\./ && !$ns_cookie) { - next SET_COOKIE; - } - } - else { - $domain = $req_host; - } - - my $path = delete $hash{path}; - my $path_spec; - if (defined $path && $path ne '') { - $path_spec++; - _normalize_path($path) if $path =~ /%/; - if (!$ns_cookie && - substr($req_path, 0, length($path)) ne $path) { - next SET_COOKIE; - } - } - else { - $path = $req_path; - $path =~ s,/[^/]*$,,; - $path = "/" unless length($path); - } - - my $port; - if (exists $hash{port}) { - $port = delete $hash{port}; - if (defined $port) { - $port =~ s/\s+//g; - my $found; - for my $p (split(/,/, $port)) { - unless ($p =~ /^\d+$/) { - next SET_COOKIE; - } - $found++ if $p eq $req_port; - } - unless ($found) { - next SET_COOKIE; - } - } - else { - $port = "_$req_port"; - } - } - $self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash) - if $self->set_cookie_ok(\%orig_hash); + if ( $k eq "discard" || $k eq "secure" ) { + $v = 1 unless defined $v; + } + next if exists $hash{$k}; # only first value is significant + $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" ) { + next SET_COOKIE; + } + $domain = ".$domain" unless $domain =~ /^\./; + if ( $domain =~ /\.\d+$/ ) { + next SET_COOKIE; + } + my $len = length($domain); + unless ( substr( $req_host, -$len ) eq $domain ) { + next SET_COOKIE; + } + my $hostpre = substr( $req_host, 0, length($req_host) - $len ); + if ( $hostpre =~ /\./ && !$ns_cookie ) { + next SET_COOKIE; + } + } + else { + $domain = $req_host; + } + + my $path = delete $hash{path}; + my $path_spec; + if ( defined $path && $path ne '' ) { + $path_spec++; + _normalize_path($path) if $path =~ /%/; + if ( !$ns_cookie + && substr( $req_path, 0, length($path) ) ne $path ) { + next SET_COOKIE; + } + } + else { + $path = $req_path; + $path =~ s,/[^/]*$,,; + $path = "/" unless length($path); + } + + my $port; + if ( exists $hash{port} ) { + $port = delete $hash{port}; + if ( defined $port ) { + $port =~ s/\s+//g; + my $found; + for my $p ( split( /,/, $port ) ) { + unless ( $p =~ /^\d+$/ ) { + next SET_COOKIE; + } + $found++ if $p eq $req_port; + } + unless ($found) { + next SET_COOKIE; + } + } + else { + $port = "_$req_port"; + } + } + $self->set_cookie( + $version, $key, $val, $path, $domain, $port, + $path_spec, $secure, $maxage, $discard, \%hash + ) if $self->set_cookie_ok( \%orig_hash ); } $response; } -sub set_cookie_ok -{ +sub set_cookie_ok { 1; } - -sub set_cookie -{ +sub set_cookie { my $self = shift; - my($version, - $key, $val, $path, $domain, $port, - $path_spec, $secure, $maxage, $discard, $rest) = @_; + my ( + $version, + $key, $val, $path, $domain, $port, + $path_spec, $secure, $maxage, $discard, $rest + ) = @_; # path and key can not be empty (key can't start with '$') - return $self if !defined($path) || $path !~ m,^/, || - !defined($key) || $key =~ m,^\$,; + return $self + if !defined($path) + || $path !~ m,^/, + || !defined($key) + || $key =~ m,^\$,; # ensure legal port - if (defined $port) { - return $self unless $port =~ /^_?\d+(?:,\d+)*$/; + if ( defined $port ) { + return $self unless $port =~ /^_?\d+(?:,\d+)*$/; } my $expires; - if (defined $maxage) { - if ($maxage <= 0) { - delete $self->{COOKIES}{$domain}{$path}{$key}; - return $self; - } - $expires = time() + $maxage; + if ( defined $maxage ) { + if ( $maxage <= 0 ) { + delete $self->{COOKIES}{$domain}{$path}{$key}; + return $self; + } + $expires = time() + $maxage; } $version = 0 unless defined $version; - my @array = ($version, $val,$port, - $path_spec, - $secure, $expires, $discard); - push(@array, {%$rest}) if defined($rest) && %$rest; + my @array = ( + $version, $val, $port, + $path_spec, + $secure, $expires, $discard + ); + push( @array, {%$rest} ) if defined($rest) && %$rest; + # trim off undefined values at end pop(@array) while !defined $array[-1]; @@ -425,197 +442,197 @@ sub set_cookie $self; } - -sub save -{ +sub save { my $self = shift; my %args = ( - file => $self->{'file'}, + file => $self->{'file'}, ignore_discard => $self->{'ignore_discard'}, @_ == 1 ? ( file => $_[0] ) : @_ ); Carp::croak('Unexpected argument to save method') if keys %args > 2; my $file = $args{'file'} || return; - open(my $fh, '>', $file) or die "Can't open $file: $!"; + open( my $fh, '>', $file ) or die "Can't open $file: $!"; print {$fh} "#LWP-Cookies-1.0\n"; - print {$fh} $self->as_string(!$args{'ignore_discard'}); + print {$fh} $self->as_string( !$args{'ignore_discard'} ); close $fh or die "Can't close $file: $!"; 1; } - -sub load -{ +sub load { my $self = shift; my $file = shift || $self->{'file'} || return; - local $/ = "\n"; # make sure we got standard record separator - open(my $fh, '<', $file) or return; + local $/ = "\n"; # make sure we got standard record separator + open( my $fh, '<', $file ) or return; # check that we have the proper header my $magic = <$fh>; chomp $magic; - unless ($magic =~ /^#LWP-Cookies-\d+\.\d+/) { + unless ( $magic =~ /^#LWP-Cookies-\d+\.\d+/ ) { warn "$file does not seem to contain cookies"; return; } # go through the file - while (my $line = <$fh>) { + while ( my $line = <$fh> ) { chomp $line; next unless $line =~ s/^Set-Cookie3:\s*//; my $cookie; - for $cookie (_split_header_words($line)) { - my($key,$val) = splice(@$cookie, 0, 2); + for $cookie ( _split_header_words($line) ) { + my ( $key, $val ) = splice( @$cookie, 0, 2 ); my %hash; while (@$cookie) { my $k = shift @$cookie; my $v = shift @$cookie; $hash{$k} = $v; } - my $version = delete $hash{version}; - my $path = delete $hash{path}; - my $domain = delete $hash{domain}; - my $port = delete $hash{port}; - my $expires = str2time(delete $hash{expires}); - - my $path_spec = exists $hash{path_spec}; delete $hash{path_spec}; - my $secure = exists $hash{secure}; delete $hash{secure}; - my $discard = exists $hash{discard}; delete $hash{discard}; - - my @array = ($version, $val, $port, $path_spec, $secure, $expires, - $discard); - push(@array, \%hash) if %hash; + my $version = delete $hash{version}; + my $path = delete $hash{path}; + my $domain = delete $hash{domain}; + my $port = delete $hash{port}; + my $expires = str2time( delete $hash{expires} ); + + my $path_spec = exists $hash{path_spec}; + delete $hash{path_spec}; + my $secure = exists $hash{secure}; + delete $hash{secure}; + my $discard = exists $hash{discard}; + delete $hash{discard}; + + my @array = ( + $version, $val, $port, $path_spec, $secure, $expires, + $discard + ); + push( @array, \%hash ) if %hash; $self->{COOKIES}{$domain}{$path}{$key} = \@array; } } 1; } - -sub revert -{ +sub revert { my $self = shift; $self->clear->load; $self; } - -sub clear -{ +sub clear { my $self = shift; - if (@_ == 0) { - $self->{COOKIES} = {}; + if ( @_ == 0 ) { + $self->{COOKIES} = {}; } - elsif (@_ == 1) { - delete $self->{COOKIES}{$_[0]}; + elsif ( @_ == 1 ) { + delete $self->{COOKIES}{ $_[0] }; } - elsif (@_ == 2) { - delete $self->{COOKIES}{$_[0]}{$_[1]}; + elsif ( @_ == 2 ) { + delete $self->{COOKIES}{ $_[0] }{ $_[1] }; } - elsif (@_ == 3) { - delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]}; + elsif ( @_ == 3 ) { + delete $self->{COOKIES}{ $_[0] }{ $_[1] }{ $_[2] }; } else { - require Carp; + require Carp; Carp::carp('Usage: $c->clear([domain [,path [,key]]])'); } $self; } - -sub clear_temporary_cookies -{ - my($self) = @_; - - $self->scan(sub { - if($_[9] or # "Discard" flag set - not $_[8]) { # No expire field? - $_[8] = -1; # Set the expire/max_age field - $self->set_cookie(@_); # Clear the cookie +sub clear_temporary_cookies { + my ($self) = @_; + + $self->scan( + sub { + if ( + $_[9] or # "Discard" flag set + not $_[8] + ) { # No expire field? + $_[8] = -1; # Set the expire/max_age field + $self->set_cookie(@_); # Clear the cookie + } } - }); + ); } - -sub DESTROY -{ +sub DESTROY { my $self = shift; - local($., $@, $!, $^E, $?); + local ( $., $@, $!, $^E, $? ); $self->save if $self->{'autosave'}; } - -sub scan -{ - my($self, $cb) = @_; - my($domain,$path,$key); - for $domain (sort keys %{$self->{COOKIES}}) { - for $path (sort keys %{$self->{COOKIES}{$domain}}) { - for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) { - my($version,$val,$port,$path_spec, - $secure,$expires,$discard,$rest) = - @{$self->{COOKIES}{$domain}{$path}{$key}}; - $rest = {} unless defined($rest); - &$cb($version,$key,$val,$path,$domain,$port, - $path_spec,$secure,$expires,$discard,$rest); - } - } +sub scan { + my ( $self, $cb ) = @_; + my ( $domain, $path, $key ); + for $domain ( sort keys %{ $self->{COOKIES} } ) { + for $path ( sort keys %{ $self->{COOKIES}{$domain} } ) { + for $key ( sort keys %{ $self->{COOKIES}{$domain}{$path} } ) { + my ( + $version, $val, $port, $path_spec, + $secure, $expires, $discard, $rest + ) = @{ $self->{COOKIES}{$domain}{$path}{$key} }; + $rest = {} unless defined($rest); + &$cb( + $version, $key, $val, $path, $domain, $port, + $path_spec, $secure, $expires, $discard, $rest + ); + } + } } } - -sub as_string -{ - my($self, $skip_discard) = @_; +sub as_string { + my ( $self, $skip_discard ) = @_; my @res; - $self->scan(sub { - my($version,$key,$val,$path,$domain,$port, - $path_spec,$secure,$expires,$discard,$rest) = @_; - return if $discard && $skip_discard; - my @h = ($key, $val); - push(@h, "path", $path); - push(@h, "domain" => $domain); - push(@h, "port" => $port) if defined $port; - push(@h, "path_spec" => undef) if $path_spec; - push(@h, "secure" => undef) if $secure; - push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires; - push(@h, "discard" => undef) if $discard; - my $k; - for $k (sort keys %$rest) { - push(@h, $k, $rest->{$k}); - } - push(@h, "version" => $version); - push(@res, "Set-Cookie3: " . join_header_words(\@h)); - }); - join("\n", @res, ""); + $self->scan( + sub { + my ( + $version, $key, $val, $path, $domain, $port, + $path_spec, $secure, $expires, $discard, $rest + ) = @_; + return if $discard && $skip_discard; + my @h = ( $key, $val ); + push( @h, "path", $path ); + push( @h, "domain" => $domain ); + push( @h, "port" => $port ) if defined $port; + push( @h, "path_spec" => undef ) if $path_spec; + push( @h, "secure" => undef ) if $secure; + push( @h, "expires" => HTTP::Date::time2isoz($expires) ) + if $expires; + push( @h, "discard" => undef ) if $discard; + my $k; + + for $k ( sort keys %$rest ) { + push( @h, $k, $rest->{$k} ); + } + push( @h, "version" => $version ); + push( @res, "Set-Cookie3: " . join_header_words( \@h ) ); + } + ); + join( "\n", @res, "" ); } -sub _host -{ - my($request, $url) = @_; - if (my $h = $request->header("Host")) { - $h =~ s/:\d+$//; # might have a port as well - return lc($h); +sub _host { + my ( $request, $url ) = @_; + if ( my $h = $request->header("Host") ) { + $h =~ s/:\d+$//; # might have a port as well + return lc($h); } - return lc($url->host); + return lc( $url->host ); } -sub _url_path -{ +sub _url_path { my $url = shift; my $path; - if($url->can('epath')) { - $path = $url->epath; # URI::URL method + if ( $url->can('epath') ) { + $path = $url->epath; # URI::URL method } else { - $path = $url->path; # URI::_generic method + $path = $url->path; # URI::_generic method } $path = "/" unless length $path; $path; } -sub _normalize_path # so that plain string compare can be used +sub _normalize_path # so that plain string compare can be used { my $x; $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/ @@ -629,35 +646,39 @@ sub _normalize_path # so that plain string compare can be used # deals with splitting values by ; and the fact that they could # be in quotes which can also have escaping. sub _split_text { - my $val = shift; - my @vals = grep { $_ ne q{} } split(/([;\\"])/, $val); + my $val = shift; + my @vals = grep { $_ ne q{} } split( /([;\\"])/, $val ); my @chunks; + # divide it up into chunks to be processed. my $in_string = 0; my @current_string; - for(my $i = 0; $i < @vals; $i++) { + for ( my $i = 0 ; $i < @vals ; $i++ ) { my $chunk = $vals[$i]; - if($in_string) { - if($chunk eq q{\\}) { + if ($in_string) { + if ( $chunk eq q{\\} ) { + # don't care about next char probably. # having said that, probably need to be appending to the chunks # just dropping this. $i++; - if($i < @vals) { + if ( $i < @vals ) { push @current_string, $vals[$i]; } - } elsif($chunk eq q{"}) { + } + elsif ( $chunk eq q{"} ) { $in_string = 0; } else { push @current_string, $chunk; } - } else { - if($chunk eq q{"}) { + } + else { + if ( $chunk eq q{"} ) { $in_string = 1; } - elsif($chunk eq q{;}) { - push @chunks, join(q{}, @current_string); + elsif ( $chunk eq q{;} ) { + push @chunks, join( q{}, @current_string ); @current_string = (); } else { @@ -665,7 +686,7 @@ sub _split_text { } } } - push @chunks, join(q{}, @current_string) if @current_string; + push @chunks, join( q{}, @current_string ) if @current_string; s/^\s+// for @chunks; return \@chunks; } diff --git a/lib/HTTP/Cookies/Microsoft.pm b/lib/HTTP/Cookies/Microsoft.pm index 333e284e..e28efd1d 100644 --- a/lib/HTTP/Cookies/Microsoft.pm +++ b/lib/HTTP/Cookies/Microsoft.pm @@ -5,44 +5,48 @@ use strict; our $VERSION = '6.12'; require HTTP::Cookies; -our @ISA=qw(HTTP::Cookies); +our @ISA = qw(HTTP::Cookies); -sub load_cookies_from_file -{ +sub load_cookies_from_file { my ($file) = @_; my @cookies; - open (my $fh, '<', $file) || return; + open( my $fh, '<', $file ) || return; - while (my $key = <$fh>) { + while ( my $key = <$fh> ) { chomp $key; - my ($value, $domain_path, $flags, $lo_expire, $hi_expire); - my ($lo_create, $hi_create, $sep); - chomp($value = <$fh>); - chomp($domain_path= <$fh>); - chomp($flags = <$fh>); # 0x0001 bit is for secure - chomp($lo_expire = <$fh>); - chomp($hi_expire = <$fh>); - chomp($lo_create = <$fh>); - chomp($hi_create = <$fh>); - chomp($sep = <$fh>); - - if (!defined($key) || !defined($value) || !defined($domain_path) || - !defined($flags) || !defined($hi_expire) || !defined($lo_expire) || - !defined($hi_create) || !defined($lo_create) || !defined($sep) || - ($sep ne '*')) - { + my ( $value, $domain_path, $flags, $lo_expire, $hi_expire ); + my ( $lo_create, $hi_create, $sep ); + chomp( $value = <$fh> ); + chomp( $domain_path = <$fh> ); + chomp( $flags = <$fh> ); # 0x0001 bit is for secure + chomp( $lo_expire = <$fh> ); + chomp( $hi_expire = <$fh> ); + chomp( $lo_create = <$fh> ); + chomp( $hi_create = <$fh> ); + chomp( $sep = <$fh> ); + + if ( !defined($key) + || !defined($value) + || !defined($domain_path) + || !defined($flags) + || !defined($hi_expire) + || !defined($lo_expire) + || !defined($hi_create) + || !defined($lo_create) + || !defined($sep) + || ( $sep ne '*' ) ) { last; } - if ($domain_path =~ /^([^\/]+)(\/.*)$/) { + if ( $domain_path =~ /^([^\/]+)(\/.*)$/ ) { my $domain = $1; - my $path = $2; + my $path = $2; push @cookies, { - KEY => $key, VALUE => $value, DOMAIN => $domain, - PATH => $path, FLAGS =>$flags, HIXP =>$hi_expire, - LOXP => $lo_expire, HICREATE => $hi_create, + KEY => $key, VALUE => $value, DOMAIN => $domain, + PATH => $path, FLAGS => $flags, HIXP => $hi_expire, + LOXP => $lo_expire, HICREATE => $hi_create, LOCREATE => $lo_create }; } @@ -51,13 +55,12 @@ sub load_cookies_from_file return \@cookies; } -sub get_user_name -{ - use Win32; - use locale; - my $user = lc(Win32::LoginName()); +sub get_user_name { + use Win32; + use locale; + my $user = lc( Win32::LoginName() ); - return $user; + return $user; } # MSIE stores create and expire times as Win32 FILETIME, @@ -66,129 +69,139 @@ sub get_user_name # But Cookies code expects time in 32-bit value expressed # in seconds since Jan 01 1970 # -sub epoch_time_offset_from_win32_filetime -{ - my ($high, $low) = @_; - - #-------------------------------------------------------- - # USEFUL CONSTANT - #-------------------------------------------------------- - # 0x019db1de 0xd53e8000 is 1970 Jan 01 00:00:00 in Win32 FILETIME - # - # 100 nanosecond intervals == 0.1 microsecond intervals - - my $filetime_low32_1970 = 0xd53e8000; - my $filetime_high32_1970 = 0x019db1de; - - #------------------------------------ - # ALGORITHM - #------------------------------------ - # To go from 100 nanosecond intervals to seconds since 00:00 Jan 01 1970: - # - # 1. Adjust 100 nanosecond intervals to Jan 01 1970 base - # 2. Divide by 10 to get to microseconds (1/millionth second) - # 3. Divide by 1000000 (10 ^ 6) to get to seconds - # - # We can combine Step 2 & 3 into one divide. - # - # After much trial and error, I came up with the following code which - # avoids using Math::BigInt or floating pt, but still gives correct answers - - # If the filetime is before the epoch, return 0 - if (($high < $filetime_high32_1970) || - (($high == $filetime_high32_1970) && ($low < $filetime_low32_1970))) - { - return 0; - } - - # Can't multiply by 0x100000000, (1 << 32), - # without Perl issuing an integer overflow warning - # - # So use two multiplies by 0x10000 instead of one multiply by 0x100000000 - # - # The result is the same. - # - my $date1970 = (($filetime_high32_1970 * 0x10000) * 0x10000) + $filetime_low32_1970; - my $time = (($high * 0x10000) * 0x10000) + $low; - - $time -= $date1970; - $time /= 10000000; - - return $time; -} +sub epoch_time_offset_from_win32_filetime { + my ( $high, $low ) = @_; + + #-------------------------------------------------------- + # USEFUL CONSTANT + #-------------------------------------------------------- + # 0x019db1de 0xd53e8000 is 1970 Jan 01 00:00:00 in Win32 FILETIME + # + # 100 nanosecond intervals == 0.1 microsecond intervals + + my $filetime_low32_1970 = 0xd53e8000; + my $filetime_high32_1970 = 0x019db1de; + + #------------------------------------ + # ALGORITHM + #------------------------------------ + # To go from 100 nanosecond intervals to seconds since 00:00 Jan 01 1970: + # + # 1. Adjust 100 nanosecond intervals to Jan 01 1970 base + # 2. Divide by 10 to get to microseconds (1/millionth second) + # 3. Divide by 1000000 (10 ^ 6) to get to seconds + # + # We can combine Step 2 & 3 into one divide. + # + # After much trial and error, I came up with the following code which + # avoids using Math::BigInt or floating pt, but still gives correct answers + + # If the filetime is before the epoch, return 0 + if ( + ( $high < $filetime_high32_1970 ) + || ( ( $high == $filetime_high32_1970 ) + && ( $low < $filetime_low32_1970 ) ) + ) { + return 0; + } -sub load_cookie -{ - my($self, $file) = @_; - my $now = time() - $HTTP::Cookies::EPOCH_OFFSET; - my $cookie_data; - - if (-f $file) - { - # open the cookie file and get the data - $cookie_data = load_cookies_from_file($file); - - foreach my $cookie (@{$cookie_data}) - { - my $secure = ($cookie->{FLAGS} & 1) != 0; - my $expires = epoch_time_offset_from_win32_filetime($cookie->{HIXP}, $cookie->{LOXP}); - - $self->set_cookie(undef, $cookie->{KEY}, $cookie->{VALUE}, - $cookie->{PATH}, $cookie->{DOMAIN}, undef, - 0, $secure, $expires-$now, 0); - } - } + # Can't multiply by 0x100000000, (1 << 32), + # without Perl issuing an integer overflow warning + # + # So use two multiplies by 0x10000 instead of one multiply by 0x100000000 + # + # The result is the same. + # + my $date1970 = ( ( $filetime_high32_1970 * 0x10000 ) * 0x10000 ) + + $filetime_low32_1970; + my $time = ( ( $high * 0x10000 ) * 0x10000 ) + $low; + + $time -= $date1970; + $time /= 10000000; + + return $time; } -sub load -{ - my($self, $cookie_index) = @_; +sub load_cookie { + my ( $self, $file ) = @_; my $now = time() - $HTTP::Cookies::EPOCH_OFFSET; + my $cookie_data; + + if ( -f $file ) { + + # open the cookie file and get the data + $cookie_data = load_cookies_from_file($file); + + foreach my $cookie ( @{$cookie_data} ) { + my $secure = ( $cookie->{FLAGS} & 1 ) != 0; + my $expires = epoch_time_offset_from_win32_filetime( + $cookie->{HIXP}, + $cookie->{LOXP} + ); + + $self->set_cookie( + undef, $cookie->{KEY}, $cookie->{VALUE}, + $cookie->{PATH}, $cookie->{DOMAIN}, undef, + 0, $secure, $expires - $now, 0 + ); + } + } +} + +sub load { + my ( $self, $cookie_index ) = @_; + my $now = time() - $HTTP::Cookies::EPOCH_OFFSET; my $cookie_dir = ''; - my $delay_load = (defined($self->{'delayload'}) && $self->{'delayload'}); + my $delay_load + = ( defined( $self->{'delayload'} ) && $self->{'delayload'} ); my $user_name = get_user_name(); my $data; $cookie_index ||= $self->{'file'} || return; - if ($cookie_index =~ /[\\\/][^\\\/]+$/) { + if ( $cookie_index =~ /[\\\/][^\\\/]+$/ ) { $cookie_dir = $` . "\\"; } - open (my $fh, '<:raw', $cookie_index) || return; - if (256 != read($fh, $data, 256)) { + open( my $fh, '<:raw', $cookie_index ) || return; + if ( 256 != read( $fh, $data, 256 ) ) { warn "$cookie_index file is not large enough"; return; } # Cookies' index.dat file starts with 32 bytes of signature # followed by an offset to the first record, stored as a little-endian DWORD - my ($sig, $size) = unpack('a32 V', $data); + my ( $sig, $size ) = unpack( 'a32 V', $data ); # check that sig is valid (only tested in IE6.0) - if (($sig !~ /^Client UrlCache MMF Ver 5\.2/) || (0x4000 != $size)) { + if ( ( $sig !~ /^Client UrlCache MMF Ver 5\.2/ ) || ( 0x4000 != $size ) ) + { warn "$cookie_index ['$sig' $size] does not seem to contain cookies"; return; } # move the file ptr to start of the first record - if (0 == seek($fh, $size, 0)) { + if ( 0 == seek( $fh, $size, 0 ) ) { return; } # Cookies are usually stored in 'URL ' records in two contiguous 0x80 byte sectors (256 bytes) # so read in two 0x80 byte sectors and adjust if not a Cookie. - while (256 == read($fh, $data, 256)) { + while ( 256 == read( $fh, $data, 256 ) ) { + # each record starts with a 4-byte signature # and a count (little-endian DWORD) of 0x80 byte sectors for the record - ($sig, $size) = unpack('a4 V', $data); + ( $sig, $size ) = unpack( 'a4 V', $data ); # Cookies are found in 'URL ' records - if ('URL ' ne $sig) { + if ( 'URL ' ne $sig ) { + # skip over uninteresting record: I've seen 'HASH' and 'LEAK' records - if (($sig eq 'HASH') || ($sig eq 'LEAK')) { + if ( ( $sig eq 'HASH' ) || ( $sig eq 'LEAK' ) ) { + # '-2' takes into account the two 0x80 byte sectors we've just read in - if (($size > 0) && ($size != 2)) { - if (0 == seek($fh, ($size-2)*0x80, 1)) { + if ( ( $size > 0 ) && ( $size != 2 ) ) { + if ( 0 == seek( $fh, ( $size - 2 ) * 0x80, 1 ) ) { + # Seek failed. Something's wrong. Gonna stop. last; } @@ -199,32 +212,37 @@ sub load #$REMOVE Need to check if URL records in Cookies' index.dat will # ever use more than two 0x80 byte sectors - if ($size > 2) { - my $more_data = ($size-2)*0x80; + if ( $size > 2 ) { + my $more_data = ( $size - 2 ) * 0x80; - if ($more_data != read($fh, $data, $more_data, 256)) { + if ( $more_data != read( $fh, $data, $more_data, 256 ) ) { last; } } - (my $user_name2 = $user_name) =~ s/ /_/g; - if ($data =~ /Cookie:\Q$user_name\E@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)@[\x21-\xFF]+\.txt)/) { - my $cookie_file = $cookie_dir . $2; # form full pathname + ( my $user_name2 = $user_name ) =~ s/ /_/g; + if ( $data + =~ /Cookie:\Q$user_name\E@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)@[\x21-\xFF]+\.txt)/ + ) { + my $cookie_file = $cookie_dir . $2; # form full pathname - if (!$delay_load) { + if ( !$delay_load ) { $self->load_cookie($cookie_file); } else { my $domain = $1; # grab only the domain name, drop everything from the first dir sep on - if ($domain =~ m{[\\/]}) { + if ( $domain =~ m{[\\/]} ) { $domain = $`; } # set the delayload cookie for this domain with # the cookie_file as cookie for later-loading info - $self->set_cookie(undef, 'cookie', $cookie_file, '//+delayload', $domain, undef, 0, 0, $now+86_400, 0); + $self->set_cookie( + undef, 'cookie', $cookie_file, + '//+delayload', $domain, undef, 0, 0, $now + 86_400, 0 + ); } } } diff --git a/lib/HTTP/Cookies/Netscape.pm b/lib/HTTP/Cookies/Netscape.pm index 16a134bd..34055e26 100644 --- a/lib/HTTP/Cookies/Netscape.pm +++ b/lib/HTTP/Cookies/Netscape.pm @@ -5,48 +5,50 @@ use strict; our $VERSION = '6.12'; require HTTP::Cookies; -our @ISA=qw(HTTP::Cookies); +our @ISA = qw(HTTP::Cookies); -sub load -{ - my ($self, $file) = @_; +sub load { + my ( $self, $file ) = @_; $file ||= $self->{'file'} || return; - local $/ = "\n"; # make sure we got standard record separator - open (my $fh, '<', $file) || return; + local $/ = "\n"; # make sure we got standard record separator + open( my $fh, '<', $file ) || return; my $magic = <$fh>; chomp $magic; - unless ($magic =~ /^#(?: Netscape)? HTTP Cookie File/) { + unless ( $magic =~ /^#(?: Netscape)? HTTP Cookie File/ ) { warn "$file does not look like a netscape cookies file"; return; } my $now = time() - $HTTP::Cookies::EPOCH_OFFSET; - while (my $line = <$fh>) { + while ( my $line = <$fh> ) { chomp($line); $line =~ s/\s*\#HttpOnly_//; next if $line =~ /^\s*\#/; next if $line =~ /^\s*$/; $line =~ tr/\n\r//d; - my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $line); - $secure = ($secure eq "TRUE"); - $self->set_cookie(undef, $key, $val, $path, $domain, undef, 0, $secure, $expires-$now, 0); + my ( $domain, $bool1, $path, $secure, $expires, $key, $val ) + = split( /\t/, $line ); + $secure = ( $secure eq "TRUE" ); + $self->set_cookie( + undef, $key, $val, $path, $domain, undef, 0, + $secure, $expires - $now, 0 + ); } 1; } -sub save -{ +sub save { my $self = shift; my %args = ( - file => $self->{'file'}, + file => $self->{'file'}, ignore_discard => $self->{'ignore_discard'}, @_ == 1 ? ( file => $_[0] ) : @_ ); Carp::croak('Unexpected argument to save method') if keys %args > 2; my $file = $args{'file'} || return; - open(my $fh, '>', $file) || return; + open( my $fh, '>', $file ) || return; # Use old, now broken link to the old cookie spec just in case something # else (not us!) requires the comment block exactly this way. @@ -58,15 +60,24 @@ sub save EOT my $now = time - $HTTP::Cookies::EPOCH_OFFSET; - $self->scan(sub { - my ($version, $key, $val, $path, $domain, $port, $path_spec, $secure, $expires, $discard, $rest) = @_; - return if $discard && !$args{'ignore_discard'}; - $expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0; - return if $now > $expires; - $secure = $secure ? "TRUE" : "FALSE"; - my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE"; - print {$fh} join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n"; - }); + $self->scan( + sub { + my ( + $version, $key, $val, $path, $domain, $port, $path_spec, + $secure, $expires, $discard, $rest + ) = @_; + return if $discard && !$args{'ignore_discard'}; + $expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0; + return if $now > $expires; + $secure = $secure ? "TRUE" : "FALSE"; + my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE"; + print {$fh} join( + "\t", $domain, $bool, $path, $secure, $expires, $key, + $val + ), + "\n"; + } + ); 1; } diff --git a/t/10-original_spec.t b/t/10-original_spec.t index b2150488..166d8b51 100644 --- a/t/10-original_spec.t +++ b/t/10-original_spec.t @@ -5,14 +5,14 @@ use warnings; use Test::More; -use HTTP::Cookies (); -use HTTP::Date (); -use HTTP::Request (); +use HTTP::Cookies (); +use HTTP::Date (); +use HTTP::Request (); use HTTP::Response (); -use URI (); +use URI (); my $expiry_string = HTTP::Date::time2str( time + 86_400 ); -my $jar = HTTP::Cookies->new(); +my $jar = HTTP::Cookies->new(); plan tests => 20; @@ -27,9 +27,10 @@ plan tests => 20; # 1.1 # Client requests a document, and receives in the response: # Set-Cookie: CUSTOMER=WILE_E_COYOTE; path=/; expires=Wednesday, 09-Nov-99 23:12:40 GMT - $res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE; path=/ ; expires=${expiry_string}"); + $res->header( "Set-Cookie" => + "CUSTOMER=WILE_E_COYOTE; path=/ ; expires=${expiry_string}" ); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 1, '1.1: res: found the cookie'); + is( count_cookies_for('www.acme.com'), 1, '1.1: res: found the cookie' ); # 1.2 # When client requests a URL in path "/" on this server, it sends: @@ -38,12 +39,16 @@ plan tests => 20; # Set-Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001; path=/ $req = request_for('www.acme.com'); $jar->add_cookie_header($req); - is($req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE", '1.2: req: customer'); - is($req->header("Cookie2"), q{$Version="1"}, '1.2: req: version'); + is( + $req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE", + '1.2: req: customer' + ); + is( $req->header("Cookie2"), q{$Version="1"}, '1.2: req: version' ); $res->request($req); - $res->header("Set-Cookie" => "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/"); + $res->header( + "Set-Cookie" => "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/" ); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 2, '1.2: res: two cookies found'); + is( count_cookies_for('www.acme.com'), 2, '1.2: res: two cookies found' ); # 1.3 # When client requests a URL in path "/" on this server, it sends: @@ -52,27 +57,40 @@ plan tests => 20; # Set-Cookie: SHIPPING=FEDEX; path=/foo $req = request_for('www.acme.com'); $jar->add_cookie_header($req); - my $h = $req->header("Cookie"); # checking header contents is easier - like($h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/, '1.3: req: first cookie found'); - like($h, qr/CUSTOMER=WILE_E_COYOTE/, '1.3: req: second cookie found'); + my $h = $req->header("Cookie"); # checking header contents is easier + like( + $h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/, + '1.3: req: first cookie found' + ); + like( $h, qr/CUSTOMER=WILE_E_COYOTE/, '1.3: req: second cookie found' ); $res->request($req); - $res->header("Set-Cookie" => "SHIPPING=FEDEX; path=/foo"); + $res->header( "Set-Cookie" => "SHIPPING=FEDEX; path=/foo" ); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 3, '1.3: res: three cookies found'); + is( + count_cookies_for('www.acme.com'), 3, + '1.3: res: three cookies found' + ); # 1.4 # When client requests a URL in path "/" on this server, it sends: # Cookie: CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001 $req = request_for('www.acme.com'); $jar->add_cookie_header($req); - $h = $req->header("Cookie"); # checking header contents is easier - like($h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/, '1.4: req: first cookie found'); - like($h, qr/CUSTOMER=WILE_E_COYOTE/, '1.4: req: second cookie found'); - unlike($h, qr/SHIPPING=FEDEX/, '1.4: req: no shipping cookie'); + $h = $req->header("Cookie"); # checking header contents is easier + like( + $h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/, + '1.4: req: first cookie found' + ); + like( $h, qr/CUSTOMER=WILE_E_COYOTE/, '1.4: req: second cookie found' ); + unlike( $h, qr/SHIPPING=FEDEX/, '1.4: req: no shipping cookie' ); $res->request($req); - $res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001"); + $res->header( "Set-Cookie" => + "CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001" ); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 3, '1.4: res: three cookies found'); + is( + count_cookies_for('www.acme.com'), 3, + '1.4: res: three cookies found' + ); # 1.5 # When client requests a URL in path "/foo" on this server, it sends: @@ -82,14 +100,21 @@ plan tests => 20; # most specific and should thus be first. $req = request_for('www.acme.com/foo'); $jar->add_cookie_header($req); - $h = $req->header("Cookie"); # checking header contents is easier - like($h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/, '1.5: req: first cookie found'); - like($h, qr/CUSTOMER=WILE_E_COYOTE/, '1.5: req: second cookie found'); - like($h, qr/SHIPPING=FEDEX/, '1.5: req: third cookie found'); + $h = $req->header("Cookie"); # checking header contents is easier + like( + $h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/, + '1.5: req: first cookie found' + ); + like( $h, qr/CUSTOMER=WILE_E_COYOTE/, '1.5: req: second cookie found' ); + like( $h, qr/SHIPPING=FEDEX/, '1.5: req: third cookie found' ); $res->request($req); - $res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001"); + $res->header( "Set-Cookie" => + "CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001" ); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 3, '1.5: res: three cookies found'); + is( + count_cookies_for('www.acme.com'), 3, + '1.5: res: three cookies found' + ); } # Second Example transaction sequence: @@ -105,15 +130,20 @@ plan tests => 20; # Set-Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001; path=/ # When client requests a URL in path "/" on this server, it sends: # Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001 - $res->header("Set-Cookie" => "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/"); + $res->header( + "Set-Cookie" => "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/" ); $jar->extract_cookies($res); $req = request_for('www.acme.com'); $jar->add_cookie_header($req); - is($req->header("Cookie"), "PART_NUMBER=ROCKET_LAUNCHER_0001", '2.1: req: cookie found'); + is( + $req->header("Cookie"), "PART_NUMBER=ROCKET_LAUNCHER_0001", + '2.1: req: cookie found' + ); $res->request($req); - $res->header("Set-Cookie" => "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/"); + $res->header( + "Set-Cookie" => "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/" ); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 1, '2.1: res: one cookie found'); + is( count_cookies_for('www.acme.com'), 1, '2.1: res: one cookie found' ); # 2.2 # Client receives: @@ -121,28 +151,40 @@ plan tests => 20; # When client requests a URL in path "/ammo" on this server, it sends: # Cookie: PART_NUMBER=RIDING_ROCKET_0023; PART_NUMBER=ROCKET_LAUNCHER_0001 # NOTE: There are two name/value pairs named "PART_NUMBER" due to the inheritance of the "/" mapping in addition to the "/ammo" mapping. - $res->header("Set-Cookie", "PART_NUMBER=RIDING_ROCKET_0023; path=/ammo"); + $res->header( + "Set-Cookie", + "PART_NUMBER=RIDING_ROCKET_0023; path=/ammo" + ); $jar->extract_cookies($res); $req = request_for('www.acme.com/ammo'); $jar->add_cookie_header($req); - my $h = $req->header("Cookie"); # checking header contents is easier - like($h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/, '2.2: req: first cookie found'); - like($h, qr/PART_NUMBER=RIDING_ROCKET_0023/, '2.2: req: second cookie found'); + my $h = $req->header("Cookie"); # checking header contents is easier + like( + $h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/, + '2.2: req: first cookie found' + ); + like( + $h, qr/PART_NUMBER=RIDING_ROCKET_0023/, + '2.2: req: second cookie found' + ); $res->request($req); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 2, '2.2: res: three cookies found'); + is( + count_cookies_for('www.acme.com'), 2, + '2.2: res: three cookies found' + ); } sub count_cookies_for { - my $host = shift; + my $host = shift; my $count = 0; - $jar->scan( sub { $_[4] eq $host && $count++ }); + $jar->scan( sub { $_[4] eq $host && $count++ } ); return $count; } sub request_for { - my $uri = URI->new('http://'.shift)->canonical; - my $req = HTTP::Request->new( GET => $uri); + my $uri = URI->new( 'http://' . shift )->canonical; + my $req = HTTP::Request->new( GET => $uri ); $req->header( Host => $uri->host_port ); return $req; } diff --git a/t/11-rfc_2965.t b/t/11-rfc_2965.t index 1dd50278..e86de939 100644 --- a/t/11-rfc_2965.t +++ b/t/11-rfc_2965.t @@ -5,10 +5,10 @@ use warnings; use Test::More; -use HTTP::Cookies (); -use HTTP::Request (); +use HTTP::Cookies (); +use HTTP::Request (); use HTTP::Response (); -use URI (); +use URI (); my $jar = HTTP::Cookies->new(); @@ -31,12 +31,17 @@ plan tests => 13; # Set-Cookie2: Customer="WILE_E_COYOTE"; Version="1"; Path="/acme" # Cookie reflects user's identity. my $res = HTTP::Response->new( 200, 'OK' ); - $res->header('Set-Cookie2' => q{Customer="WILE_E_COYOTE"; Version="1"; Path="/acme"}); - my $req = request_for('www.acme.com/acme/login', 'POST'); + $res->header( 'Set-Cookie2' => + q{Customer="WILE_E_COYOTE"; Version="1"; Path="/acme"} ); + my $req = request_for( 'www.acme.com/acme/login', 'POST' ); + # we can skip the form data as it's not necessary here $res->request($req); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 1, '1.1-2: res: found the cookie'); + is( + count_cookies_for('www.acme.com'), 1, + '1.1-2: res: found the cookie' + ); # 3-4 # 3. User Agent -> Server @@ -48,14 +53,19 @@ plan tests => 13; # HTTP/1.1 200 OK # Set-Cookie2: Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme" # Shopping basket contains an item. - $req = request_for('www.acme.com/acme/pickitem', 'POST'); + $req = request_for( 'www.acme.com/acme/pickitem', 'POST' ); $jar->add_cookie_header($req); - my $h = $req->header("Cookie"); # checking header contents is easier - like($h, qr/Customer="?WILE_E_COYOTE"?/, '1.3-4: req: contains header'); - $res->header('Set-Cookie2' => q{Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"}); + my $h = $req->header("Cookie"); # checking header contents is easier + like( $h, qr/Customer="?WILE_E_COYOTE"?/, '1.3-4: req: contains header' ); + $res->header( 'Set-Cookie2' => + q{Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"} + ); $res->request($req); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 2, '1.3-4: res: found the cookies'); + is( + count_cookies_for('www.acme.com'), 2, + '1.3-4: res: found the cookies' + ); # 5-6 # 5. User Agent -> Server @@ -69,15 +79,22 @@ plan tests => 13; # HTTP/1.1 200 OK # Set-Cookie2: Shipping="FedEx"; Version="1"; Path="/acme" # New cookie reflects shipping method. - $req = request_for('www.acme.com/acme/shipping', 'POST'); + $req = request_for( 'www.acme.com/acme/shipping', 'POST' ); $jar->add_cookie_header($req); - $h = $req->header("Cookie"); # checking header contents is easier - like($h, qr/Customer="?WILE_E_COYOTE"?/, '1.5-6: req: contains cust'); - like($h, qr/Part_Number="?Rocket_Launcher_0001"?/, '1.5-6: req: contains part'); - $res->header('Set-Cookie2' => q{Shipping="FedEx"; Version="1"; Path="/acme"}); + $h = $req->header("Cookie"); # checking header contents is easier + like( $h, qr/Customer="?WILE_E_COYOTE"?/, '1.5-6: req: contains cust' ); + like( + $h, qr/Part_Number="?Rocket_Launcher_0001"?/, + '1.5-6: req: contains part' + ); + $res->header( + 'Set-Cookie2' => q{Shipping="FedEx"; Version="1"; Path="/acme"} ); $res->request($req); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 3, '1.5-6: res: found the cookies'); + is( + count_cookies_for('www.acme.com'), 3, + '1.5-6: res: found the cookies' + ); # 7-8 # 7. User Agent -> Server @@ -91,16 +108,22 @@ plan tests => 13; # 8. Server -> User Agent # HTTP/1.1 200 OK # Transaction is complete. - $req = request_for('www.acme.com/acme/process', 'POST'); + $req = request_for( 'www.acme.com/acme/process', 'POST' ); $jar->add_cookie_header($req); - $h = $req->header("Cookie"); # checking header contents is easier - like($h, qr/Customer="?WILE_E_COYOTE"?/, '1.7-8: req: contains cust'); - like($h, qr/Part_Number="?Rocket_Launcher_0001"?/, '1.7-8: req: contains part'); - like($h, qr/Shipping="?FedEx"?/, '1.7-8: req: contains shipping'); + $h = $req->header("Cookie"); # checking header contents is easier + like( $h, qr/Customer="?WILE_E_COYOTE"?/, '1.7-8: req: contains cust' ); + like( + $h, qr/Part_Number="?Rocket_Launcher_0001"?/, + '1.7-8: req: contains part' + ); + like( $h, qr/Shipping="?FedEx"?/, '1.7-8: req: contains shipping' ); $res = HTTP::Response->new( 200, 'OK' ); $res->request($req); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 3, '1.7-8: res: found the cookies'); + is( + count_cookies_for('www.acme.com'), 3, + '1.7-8: res: found the cookies' + ); } # Example 2 @@ -110,41 +133,54 @@ plan tests => 13; { $jar->clear(); my $res = HTTP::Response->new( 200, 'OK' ); + # requests to /acme get rocket launcher - $res->push_header('Set-Cookie2' => q{Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"}); + $res->push_header( 'Set-Cookie2' => + q{Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"} + ); + # requests to /acme/ammo will get rocket launcher and rocket - $res->push_header('Set-Cookie2' => q{Part_Number="Riding_Rocket_0023"; Version="1"; Path="/acme/ammo"}); + $res->push_header( 'Set-Cookie2' => + q{Part_Number="Riding_Rocket_0023"; Version="1"; Path="/acme/ammo"} + ); + # requests to /acme/anything_else will just get rocket launcher - my $req = request_for('www.acme.com/acme/', 'POST'); + my $req = request_for( 'www.acme.com/acme/', 'POST' ); $res->request($req); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 1, '2: acme: res: one cookie'); + is( count_cookies_for('www.acme.com'), 1, '2: acme: res: one cookie' ); $jar->clear(); - $req = request_for('www.acme.com/acme/ammo', 'POST'); + $req = request_for( 'www.acme.com/acme/ammo', 'POST' ); $res->request($req); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 2, '2: acme/ammo: res: two cookies'); + is( + count_cookies_for('www.acme.com'), 2, + '2: acme/ammo: res: two cookies' + ); $jar->clear(); - $req = request_for('www.acme.com/acme/parts', 'POST'); + $req = request_for( 'www.acme.com/acme/parts', 'POST' ); $res->request($req); $jar->extract_cookies($res); - is(count_cookies_for('www.acme.com'), 1, '2: acme/parts: res: one cookie'); + is( + count_cookies_for('www.acme.com'), 1, + '2: acme/parts: res: one cookie' + ); } sub count_cookies_for { - my $host = shift; + my $host = shift; my $count = 0; - $jar->scan(sub { $_[4] eq $host && $count++ }); + $jar->scan( sub { $_[4] eq $host && $count++ } ); return $count; } sub request_for { - my $uri = URI->new('http://'.shift); + my $uri = URI->new( 'http://' . shift ); my $method = shift || 'GET'; - my $req = HTTP::Request->new($method => $uri); - $req->header(Host => $uri->host_port); + my $req = HTTP::Request->new( $method => $uri ); + $req->header( Host => $uri->host_port ); return $req; } diff --git a/t/cookies.t b/t/cookies.t index 1106de81..4c23beab 100644 --- a/t/cookies.t +++ b/t/cookies.t @@ -1,9 +1,9 @@ #!perl -w -use HTTP::Cookies (); -use HTTP::Request (); +use HTTP::Cookies (); +use HTTP::Request (); use HTTP::Response (); -use URI (); +use URI (); use Test::More tests => 79; @@ -47,56 +47,57 @@ my $year_plus_one = (localtime)[5] + 1900 + 1; $c = HTTP::Cookies->new; -$req = HTTP::Request->new(GET => "http://1.1.1.1/"); -$req->header("Host", "www.acme.com:80"); +$req = HTTP::Request->new( GET => "http://1.1.1.1/" ); +$req->header( "Host", "www.acme.com:80" ); -$res = HTTP::Response->new(200, "OK"); +$res = HTTP::Response->new( 200, "OK" ); $res->request($req); -$res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE; path=/ ; expires=Wednesday, 09-Nov-$year_plus_one 23:12:40 GMT"); +$res->header( "Set-Cookie" => + "CUSTOMER=WILE_E_COYOTE; path=/ ; expires=Wednesday, 09-Nov-$year_plus_one 23:12:40 GMT" +); + #print $res->as_string; $c->extract_cookies($res); -$req = HTTP::Request->new(GET => "http://www.acme.com/"); +$req = HTTP::Request->new( GET => "http://www.acme.com/" ); $c->add_cookie_header($req); -is($req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE"); -is($req->header("Cookie2"), "\$Version=\"1\""); +is( $req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE" ); +is( $req->header("Cookie2"), "\$Version=\"1\"" ); $res->request($req); -$res->header("Set-Cookie" => "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/"); +$res->header( "Set-Cookie" => "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/" ); $c->extract_cookies($res); -$req = HTTP::Request->new(GET => "http://www.acme.com/foo/bar"); +$req = HTTP::Request->new( GET => "http://www.acme.com/foo/bar" ); $c->add_cookie_header($req); $h = $req->header("Cookie"); -like($h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/); -like($h, qr/CUSTOMER=WILE_E_COYOTE/); +like( $h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/ ); +like( $h, qr/CUSTOMER=WILE_E_COYOTE/ ); $res->request($req); -$res->header("Set-Cookie", "SHIPPING=FEDEX; path=/foo"); +$res->header( "Set-Cookie", "SHIPPING=FEDEX; path=/foo" ); $c->extract_cookies($res); -$req = HTTP::Request->new(GET => "http://www.acme.com/"); +$req = HTTP::Request->new( GET => "http://www.acme.com/" ); $c->add_cookie_header($req); $h = $req->header("Cookie"); -like($h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/); -like($h, qr/CUSTOMER=WILE_E_COYOTE/); -unlike($h, qr/SHIPPING=FEDEX/); - +like( $h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/ ); +like( $h, qr/CUSTOMER=WILE_E_COYOTE/ ); +unlike( $h, qr/SHIPPING=FEDEX/ ); -$req = HTTP::Request->new(GET => "http://www.acme.com/foo/"); +$req = HTTP::Request->new( GET => "http://www.acme.com/foo/" ); $c->add_cookie_header($req); $h = $req->header("Cookie"); -like($h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/); -like($h, qr/CUSTOMER=WILE_E_COYOTE/); -like($h, qr/^SHIPPING=FEDEX;/); +like( $h, qr/PART_NUMBER=ROCKET_LAUNCHER_0001/ ); +like( $h, qr/CUSTOMER=WILE_E_COYOTE/ ); +like( $h, qr/^SHIPPING=FEDEX;/ ); print $c->as_string; - # Second Example transaction sequence: # # Assume all mappings from above have been cleared. @@ -120,42 +121,42 @@ print $c->as_string; # NOTE: There are two name/value pairs named "PART_NUMBER" due to # the inheritance of the "/" mapping in addition to the "/ammo" mapping. -$c = HTTP::Cookies->new; # clear it +$c = HTTP::Cookies->new; # clear it -$req = HTTP::Request->new(GET => "http://www.acme.com/"); -$res = HTTP::Response->new(200, "OK"); +$req = HTTP::Request->new( GET => "http://www.acme.com/" ); +$res = HTTP::Response->new( 200, "OK" ); $res->request($req); -$res->header("Set-Cookie", "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/"); +$res->header( "Set-Cookie", "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/" ); $c->extract_cookies($res); -$req = HTTP::Request->new(GET => "http://www.acme.com/"); +$req = HTTP::Request->new( GET => "http://www.acme.com/" ); $c->add_cookie_header($req); -is($req->header("Cookie"), "PART_NUMBER=ROCKET_LAUNCHER_0001"); +is( $req->header("Cookie"), "PART_NUMBER=ROCKET_LAUNCHER_0001" ); $res->request($req); -$res->header("Set-Cookie", "PART_NUMBER=RIDING_ROCKET_0023; path=/ammo"); +$res->header( "Set-Cookie", "PART_NUMBER=RIDING_ROCKET_0023; path=/ammo" ); $c->extract_cookies($res); -$req = HTTP::Request->new(GET => "http://www.acme.com/ammo"); +$req = HTTP::Request->new( GET => "http://www.acme.com/ammo" ); $c->add_cookie_header($req); -like($req->header("Cookie"), - qr/^PART_NUMBER=RIDING_ROCKET_0023;\s*PART_NUMBER=ROCKET_LAUNCHER_0001/); +like( + $req->header("Cookie"), + qr/^PART_NUMBER=RIDING_ROCKET_0023;\s*PART_NUMBER=ROCKET_LAUNCHER_0001/ +); print $c->as_string; undef($c); - #------------------------------------------------------------------- # When there are no "Set-Cookie" header, then even responses # without any request URLs connected should be allowed. $c = HTTP::Cookies->new; -$c->extract_cookies(HTTP::Response->new("200", "OK")); -is(count_cookies($c), 0); - +$c->extract_cookies( HTTP::Response->new( "200", "OK" ) ); +is( count_cookies($c), 0 ); #------------------------------------------------------------------- # Then we test with the examples from RFC 2965. @@ -184,9 +185,11 @@ $c = HTTP::Cookies->new; # # Cookie reflects user's identity. -$cookie = interact($c, 'http://www.acme.com/acme/login', - 'Customer="WILE_E_COYOTE"; Version="1"; Path="/acme"'); -ok(!$cookie); +$cookie = interact( + $c, 'http://www.acme.com/acme/login', + 'Customer="WILE_E_COYOTE"; Version="1"; Path="/acme"' +); +ok( !$cookie ); # # 3. User Agent -> Server @@ -205,9 +208,14 @@ ok(!$cookie); # # Shopping basket contains an item. -$cookie = interact($c, 'http://www.acme.com/acme/pickitem', - 'Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"'); -like($cookie, qr(^\$Version="?1"?; Customer="?WILE_E_COYOTE"?; \$Path="/acme"$)); +$cookie = interact( + $c, 'http://www.acme.com/acme/pickitem', + 'Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"' +); +like( + $cookie, + qr(^\$Version="?1"?; Customer="?WILE_E_COYOTE"?; \$Path="/acme"$) +); # # 5. User Agent -> Server @@ -227,12 +235,14 @@ like($cookie, qr(^\$Version="?1"?; Customer="?WILE_E_COYOTE"?; \$Path="/acme"$)) # # New cookie reflects shipping method. -$cookie = interact($c, "http://www.acme.com/acme/shipping", - 'Shipping="FedEx"; Version="1"; Path="/acme"'); +$cookie = interact( + $c, "http://www.acme.com/acme/shipping", + 'Shipping="FedEx"; Version="1"; Path="/acme"' +); -like($cookie, qr/^\$Version="?1"?;/); -like($cookie, qr/Part_Number="?Rocket_Launcher_0001"?;\s*\$Path="\/acme"/); -like($cookie, qr/Customer="?WILE_E_COYOTE"?;\s*\$Path="\/acme"/); +like( $cookie, qr/^\$Version="?1"?;/ ); +like( $cookie, qr/Part_Number="?Rocket_Launcher_0001"?;\s*\$Path="\/acme"/ ); +like( $cookie, qr/Customer="?WILE_E_COYOTE"?;\s*\$Path="\/acme"/ ); # # 7. User Agent -> Server @@ -252,10 +262,10 @@ like($cookie, qr/Customer="?WILE_E_COYOTE"?;\s*\$Path="\/acme"/); # # Transaction is complete. -$cookie = interact($c, "http://www.acme.com/acme/process"); +$cookie = interact( $c, "http://www.acme.com/acme/process" ); print "FINAL COOKIE: $cookie\n"; -like($cookie, qr/Shipping="?FedEx"?;\s*\$Path="\/acme"/); -like($cookie, qr/WILE_E_COYOTE/); +like( $cookie, qr/Shipping="?FedEx"?;\s*\$Path="\/acme"/ ); +like( $cookie, qr/WILE_E_COYOTE/ ); # # The user agent makes a series of requests on the origin server, after @@ -266,7 +276,6 @@ like($cookie, qr/WILE_E_COYOTE/); print $c->as_string; - # 5.2 Example 2 # # This example illustrates the effect of the Path attribute. All detail @@ -286,9 +295,11 @@ $c = HTTP::Cookies->new; # Set-Cookie2: Part_Number="Riding_Rocket_0023"; Version="1"; # Path="/acme/ammo" -interact($c, "http://www.acme.com/acme/ammo/specific", - 'Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"', - 'Part_Number="Riding_Rocket_0023"; Version="1"; Path="/acme/ammo"'); +interact( + $c, "http://www.acme.com/acme/ammo/specific", + 'Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"', + 'Part_Number="Riding_Rocket_0023"; Version="1"; Path="/acme/ammo"' +); # A subsequent request by the user agent to the (same) server for URLs of # the form /acme/ammo/... would include the following request header: @@ -302,8 +313,8 @@ interact($c, "http://www.acme.com/acme/ammo/specific", # attribute, /acme. Further note that the same cookie name appears more # than once. -$cookie = interact($c, "http://www.acme.com/acme/ammo/..."); -like($cookie, qr/Riding_Rocket_0023.*Rocket_Launcher_0001/); +$cookie = interact( $c, "http://www.acme.com/acme/ammo/..." ); +like( $cookie, qr/Riding_Rocket_0023.*Rocket_Launcher_0001/ ); # A subsequent request by the user agent to the (same) server for a URL of # the form /acme/parts/ would include the following request header: @@ -314,9 +325,9 @@ like($cookie, qr/Riding_Rocket_0023.*Rocket_Launcher_0001/); # the request URL, /acme/parts/, so the cookie does not get forwarded to # the server. -$cookie = interact($c, "http://www.acme.com/acme/parts/"); -like($cookie, qr/Rocket_Launcher_0001/); -unlike($cookie, qr/Riding_Rocket_0023/); +$cookie = interact( $c, "http://www.acme.com/acme/parts/" ); +like( $cookie, qr/Rocket_Launcher_0001/ ); +unlike( $cookie, qr/Riding_Rocket_0023/ ); print $c->as_string; @@ -327,48 +338,70 @@ print $c->as_string; $c = HTTP::Cookies->new; # illegal domain (no embedded dots) -$cookie = interact($c, "http://www.acme.com", 'foo=bar; domain=".com"'); -is(count_cookies($c), 0); +$cookie = interact( $c, "http://www.acme.com", 'foo=bar; domain=".com"' ); +is( count_cookies($c), 0 ); # legal domain -$cookie = interact($c, "http://www.acme.com", 'foo=bar; domain="acme.com"'); -is(count_cookies($c), 1); +$cookie = interact( $c, "http://www.acme.com", 'foo=bar; domain="acme.com"' ); +is( count_cookies($c), 1 ); # illegal domain (host prefix "www.a" contains a dot) -$cookie = interact($c, "http://www.a.acme.com", 'foo=bar; domain="acme.com"'); -is(count_cookies($c), 1); +$cookie + = interact( $c, "http://www.a.acme.com", 'foo=bar; domain="acme.com"' ); +is( count_cookies($c), 1 ); # legal domain -$cookie = interact($c, "http://www.a.acme.com", 'foo=bar; domain=".a.acme.com"'); -is(count_cookies($c), 2); +$cookie = interact( + $c, "http://www.a.acme.com", + 'foo=bar; domain=".a.acme.com"' +); +is( count_cookies($c), 2 ); # can't use a IP-address as domain -$cookie = interact($c, "http://125.125.125.125", 'foo=bar; domain="125.125.125"'); -is(count_cookies($c), 2); +$cookie = interact( + $c, "http://125.125.125.125", + 'foo=bar; domain="125.125.125"' +); +is( count_cookies($c), 2 ); # illegal path (must be prefix of request path) -$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; path="/foo"'); -is(count_cookies($c), 2); +$cookie = interact( + $c, "http://www.sol.no", + 'foo=bar; domain=".sol.no"; path="/foo"' +); +is( count_cookies($c), 2 ); # legal path -$cookie = interact($c, "http://www.sol.no/foo/bar", 'foo=bar; domain=".sol.no"; path="/foo"'); -is(count_cookies($c), 3); +$cookie = interact( + $c, "http://www.sol.no/foo/bar", + 'foo=bar; domain=".sol.no"; path="/foo"' +); +is( count_cookies($c), 3 ); # illegal port (request-port not in list) -$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; port="90,100"'); -is(count_cookies($c), 3); +$cookie = interact( + $c, "http://www.sol.no", + 'foo=bar; domain=".sol.no"; port="90,100"' +); +is( count_cookies($c), 3 ); # legal port -$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; port="90,100, 80,8080"; max-age=100; Comment = "Just kidding! (\"|\\\\) "'); -is(count_cookies($c), 4); +$cookie = interact( + $c, "http://www.sol.no", + 'foo=bar; domain=".sol.no"; port="90,100, 80,8080"; max-age=100; Comment = "Just kidding! (\"|\\\\) "' +); +is( count_cookies($c), 4 ); # port attribute without any value (current port) -$cookie = interact($c, "http://www.sol.no", 'foo9=bar; domain=".sol.no"; port; max-age=100;'); -is(count_cookies($c), 5); +$cookie = interact( + $c, "http://www.sol.no", + 'foo9=bar; domain=".sol.no"; port; max-age=100;' +); +is( count_cookies($c), 5 ); # encoded path -$cookie = interact($c, "http://www.sol.no/foo/", 'foo8=bar; path="/%66oo"'); -is(count_cookies($c), 6); +$cookie = interact( $c, "http://www.sol.no/foo/", 'foo8=bar; path="/%66oo"' ); +is( count_cookies($c), 6 ); my $file = "lwp-cookies-$$.txt"; $c->save($file); @@ -379,7 +412,7 @@ $c = HTTP::Cookies->new; $c->load($file); unlink($file) || warn "Can't unlink $file: $!"; -is($old, $c->as_string); +is( $old, $c->as_string ); undef($c); @@ -387,15 +420,21 @@ undef($c); # Try some URL encodings of the PATHs # $c = HTTP::Cookies->new; -interact($c, "http://www.acme.com/foo%2f%25/%40%40%0Anew%E5/%E5", 'foo = bar; version = 1'); +interact( + $c, "http://www.acme.com/foo%2f%25/%40%40%0Anew%E5/%E5", + 'foo = bar; version = 1' +); print $c->as_string; -$cookie = interact($c, "http://www.acme.com/foo%2f%25/@@%0anewå/æøå", "bar=baz; path=\"/foo/\"; version=1"); -like($cookie, qr/foo=bar/); -like($cookie, qr/^\$version=\"?1\"?/i); +$cookie = interact( + $c, "http://www.acme.com/foo%2f%25/@@%0anewå/æøå", + "bar=baz; path=\"/foo/\"; version=1" +); +like( $cookie, qr/foo=bar/ ); +like( $cookie, qr/^\$version=\"?1\"?/i ); -$cookie = interact($c, "http://www.acme.com/foo/%25/@@%0anewå/æøå"); -ok(!$cookie); +$cookie = interact( $c, "http://www.acme.com/foo/%25/@@%0anewå/æøå" ); +ok( !$cookie ); undef($c); @@ -403,67 +442,70 @@ undef($c); # Try to use the Netscape cookie file format for saving # $file = "cookies-$$.txt"; -$c = HTTP::Cookies::Netscape->new(file => $file); -interact($c, "http://www.acme.com/", "foo1=bar; max-age=100"); -interact($c, "http://www.acme.com/", "foo2=bar; port=\"80\"; max-age=100; Discard; Version=1"); -interact($c, "http://www.acme.com/", "foo3=bar; secure; Version=1"); +$c = HTTP::Cookies::Netscape->new( file => $file ); +interact( $c, "http://www.acme.com/", "foo1=bar; max-age=100" ); +interact( + $c, "http://www.acme.com/", + "foo2=bar; port=\"80\"; max-age=100; Discard; Version=1" +); +interact( $c, "http://www.acme.com/", "foo3=bar; secure; Version=1" ); $c->save; undef($c); -$c = HTTP::Cookies::Netscape->new(file => $file); -is(count_cookies($c), 1); # 2 of them discarded on save +$c = HTTP::Cookies::Netscape->new( file => $file ); +is( count_cookies($c), 1 ); # 2 of them discarded on save -like($c->as_string, qr/foo1=bar/); +like( $c->as_string, qr/foo1=bar/ ); undef($c); unlink($file); # Expect a HttpOnly cookie to be loaded, rather than treated as a comment -$c = HTTP::Cookies::Netscape->new(file => 't/data/netscape-httponly.txt'); -is(count_cookies($c), 4); +$c = HTTP::Cookies::Netscape->new( file => 't/data/netscape-httponly.txt' ); +is( count_cookies($c), 4 ); undef($c); # # Some additional Netscape cookies test # -$c = HTTP::Cookies->new; -$req = HTTP::Request->new(POST => "http://foo.bar.acme.com/foo"); +$c = HTTP::Cookies->new; +$req = HTTP::Request->new( POST => "http://foo.bar.acme.com/foo" ); # Netscape allows a host part that contains dots -$res = HTTP::Response->new(200, "OK"); -$res->header(set_cookie => 'Customer=WILE_E_COYOTE; domain=.acme.com'); +$res = HTTP::Response->new( 200, "OK" ); +$res->header( set_cookie => 'Customer=WILE_E_COYOTE; domain=.acme.com' ); $res->request($req); $c->extract_cookies($res); # and that the domain is the same as the host without adding a leading # dot to the domain. Should not quote even if strange chars are used # in the cookie value. -$res = HTTP::Response->new(200, "OK"); -$res->header(set_cookie => 'PART_NUMBER=3,4; domain=foo.bar.acme.com'); +$res = HTTP::Response->new( 200, "OK" ); +$res->header( set_cookie => 'PART_NUMBER=3,4; domain=foo.bar.acme.com' ); $res->request($req); $c->extract_cookies($res); print $c->as_string; -$req = HTTP::Request->new(POST => URI->new("http://foo.bar.acme.com/foo")); +$req = HTTP::Request->new( POST => URI->new("http://foo.bar.acme.com/foo") ); $c->add_cookie_header($req); -#print $req->as_string; -like($req->header("Cookie"), qr/PART_NUMBER=3,4/); -like($req->header("Cookie"), qr/Customer=WILE_E_COYOTE/); +#print $req->as_string; +like( $req->header("Cookie"), qr/PART_NUMBER=3,4/ ); +like( $req->header("Cookie"), qr/Customer=WILE_E_COYOTE/ ); # Test handling of local intranet hostnames without a dot $c->clear; print "---\n"; -interact($c, "http://example/", "foo1=bar; PORT; Discard;"); -$_=interact($c, "http://example/", 'foo2=bar; domain=".local"'); -like($_, qr/foo1=bar/); +interact( $c, "http://example/", "foo1=bar; PORT; Discard;" ); +$_ = interact( $c, "http://example/", 'foo2=bar; domain=".local"' ); +like( $_, qr/foo1=bar/ ); -$_=interact($c, "http://example/", 'foo3=bar'); -$_=interact($c, "http://example/"); +$_ = interact( $c, "http://example/", 'foo3=bar' ); +$_ = interact( $c, "http://example/" ); print "Cookie: $_\n"; -like($_, qr/foo2=bar/); -is(count_cookies($c), 3); +like( $_, qr/foo2=bar/ ); +is( count_cookies($c), 3 ); print $c->as_string; # Test for empty path @@ -475,32 +517,34 @@ print $c->as_string; # In this case routine extract_cookies() must set cookie to / (root) print "---\n"; print "Test for empty path...\n"; -$c = HTTP::Cookies->new; # clear it +$c = HTTP::Cookies->new; # clear it -$req = HTTP::Request->new(GET => "http://www.ants.com/"); +$req = HTTP::Request->new( GET => "http://www.ants.com/" ); -$res = HTTP::Response->new(200, "OK"); +$res = HTTP::Response->new( 200, "OK" ); $res->request($req); -$res->header("Set-Cookie" => "JSESSIONID=ABCDERANDOM123; Path="); +$res->header( "Set-Cookie" => "JSESSIONID=ABCDERANDOM123; Path=" ); print $res->as_string; $c->extract_cookies($res); + #print $c->as_string; -$req = HTTP::Request->new(GET => "http://www.ants.com/"); +$req = HTTP::Request->new( GET => "http://www.ants.com/" ); $c->add_cookie_header($req); -#print $req->as_string; -is($req->header("Cookie"), "JSESSIONID=ABCDERANDOM123"); -is($req->header("Cookie2"), "\$Version=\"1\""); +#print $req->as_string; +is( $req->header("Cookie"), "JSESSIONID=ABCDERANDOM123" ); +is( $req->header("Cookie2"), "\$Version=\"1\"" ); # missing path in the request URI -$req = HTTP::Request->new(GET => URI->new("http://www.ants.com:8080")); +$req = HTTP::Request->new( GET => URI->new("http://www.ants.com:8080") ); $c->add_cookie_header($req); + #print $req->as_string; -is($req->header("Cookie"), "JSESSIONID=ABCDERANDOM123"); -is($req->header("Cookie2"), "\$Version=\"1\""); +is( $req->header("Cookie"), "JSESSIONID=ABCDERANDOM123" ); +is( $req->header("Cookie2"), "\$Version=\"1\"" ); # test mixing of Set-Cookie and Set-Cookie2 headers. # Example from http://www.trip.com/trs/trip/flighttracker/flight_tracker_home.xsl @@ -521,18 +565,24 @@ is($req->header("Cookie2"), "\$Version=\"1\""); # X-Meta-Description: Trip.com privacy policy # X-Meta-Keywords: privacy policy -$req = HTTP::Request->new('GET', 'http://www.trip.com/trs/trip/flighttracker/flight_tracker_home.xsl'); -$res = HTTP::Response->new(200, "OK"); +$req = HTTP::Request->new( + 'GET', + 'http://www.trip.com/trs/trip/flighttracker/flight_tracker_home.xsl' +); +$res = HTTP::Response->new( 200, "OK" ); $res->request($req); -$res->push_header("Set-Cookie" => qq(trip.appServer=1111-0000-x-024;Domain=.trip.com;Path=/)); -$res->push_header("Set-Cookie" => qq(JSESSIONID=fkumjm7nt1.JS24;Path=/trs)); -$res->push_header("Set-Cookie2" => qq(JSESSIONID=fkumjm7nt1.JS24;Version=1;Discard;Path="/trs")); +$res->push_header( "Set-Cookie" => + qq(trip.appServer=1111-0000-x-024;Domain=.trip.com;Path=/) ); +$res->push_header( "Set-Cookie" => qq(JSESSIONID=fkumjm7nt1.JS24;Path=/trs) ); +$res->push_header( "Set-Cookie2" => + qq(JSESSIONID=fkumjm7nt1.JS24;Version=1;Discard;Path="/trs") ); + #print $res->as_string; -$c = HTTP::Cookies->new; # clear it +$c = HTTP::Cookies->new; # clear it $c->extract_cookies($res); print $c->as_string; -is($c->as_string, <<'EOT'); +is( $c->as_string, <<'EOT' ); Set-Cookie3: trip.appServer=1111-0000-x-024; path="/"; domain=.trip.com; path_spec; discard; version=0 Set-Cookie3: JSESSIONID=fkumjm7nt1.JS24; path="/trs"; domain=www.trip.com; path_spec; discard; version=1 EOT @@ -541,167 +591,212 @@ EOT # Test if temporary cookies are deleted properly with # $jar->clear_temporary_cookies() -$req = HTTP::Request->new('GET', 'http://www.perlmeister.com/scripts'); -$res = HTTP::Response->new(200, "OK"); +$req = HTTP::Request->new( 'GET', 'http://www.perlmeister.com/scripts' ); +$res = HTTP::Response->new( 200, "OK" ); $res->request($req); - # Set session/perm cookies and mark their values as "session" vs. "perm" - # to recognize them later -$res->push_header("Set-Cookie" => qq(s1=session;Path=/scripts)); -$res->push_header("Set-Cookie" => qq(p1=perm; Domain=.perlmeister.com;Path=/;expires=Fri, 02-Feb-$year_plus_one 23:24:20 GMT)); -$res->push_header("Set-Cookie" => qq(p2=perm;Path=/;expires=Fri, 02-Feb-$year_plus_one 23:24:20 GMT)); -$res->push_header("Set-Cookie" => qq(s2=session;Path=/scripts;Domain=.perlmeister.com)); -$res->push_header("Set-Cookie2" => qq(s3=session;Version=1;Discard;Path="/")); - -$c = HTTP::Cookies->new; # clear jar + +# Set session/perm cookies and mark their values as "session" vs. "perm" +# to recognize them later +$res->push_header( "Set-Cookie" => qq(s1=session;Path=/scripts) ); +$res->push_header( "Set-Cookie" => + qq(p1=perm; Domain=.perlmeister.com;Path=/;expires=Fri, 02-Feb-$year_plus_one 23:24:20 GMT) +); +$res->push_header( "Set-Cookie" => + qq(p2=perm;Path=/;expires=Fri, 02-Feb-$year_plus_one 23:24:20 GMT) ); +$res->push_header( + "Set-Cookie" => qq(s2=session;Path=/scripts;Domain=.perlmeister.com) ); +$res->push_header( + "Set-Cookie2" => qq(s3=session;Version=1;Discard;Path="/") ); + +$c = HTTP::Cookies->new; # clear jar $c->extract_cookies($res); + # How many session/permanent cookies do we have? -my %counter = ("session_after" => 0); +my %counter = ( "session_after" => 0 ); $c->scan( sub { $counter{"${_[2]}_before"}++ } ); $c->clear_temporary_cookies(); + # How many now? $c->scan( sub { $counter{"${_[2]}_after"}++ } ); -is($counter{"perm_after"}, $counter{"perm_before"}); # a permanent cookie got lost accidently -is($counter{"session_after"}, 0); # a session cookie hasn't been cleared -is($counter{"session_before"}, 3); # we didn't have session cookies in the first place -#print $c->as_string; +is( $counter{"perm_after"}, $counter{"perm_before"} ) + ; # a permanent cookie got lost accidently +is( $counter{"session_after"}, 0 ); # a session cookie hasn't been cleared +is( $counter{"session_before"}, 3 ) + ; # we didn't have session cookies in the first place +#print $c->as_string; # Test handling of 'secure ' attribute for classic cookies -$c = HTTP::Cookies->new; -$req = HTTP::Request->new(GET => "https://1.1.1.1/"); -$req->header("Host", "www.acme.com:80"); +$c = HTTP::Cookies->new; +$req = HTTP::Request->new( GET => "https://1.1.1.1/" ); +$req->header( "Host", "www.acme.com:80" ); -$res = HTTP::Response->new(200, "OK"); +$res = HTTP::Response->new( 200, "OK" ); $res->request($req); -$res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE ; secure ; path=/"); +$res->header( "Set-Cookie" => "CUSTOMER=WILE_E_COYOTE ; secure ; path=/" ); + #print $res->as_string; $c->extract_cookies($res); -$req = HTTP::Request->new(GET => "http://www.acme.com/"); +$req = HTTP::Request->new( GET => "http://www.acme.com/" ); $c->add_cookie_header($req); -ok(!$req->header("Cookie")); +ok( !$req->header("Cookie") ); $req->uri->scheme("https"); $c->add_cookie_header($req); -is($req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE"); +is( $req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE" ); #print $req->as_string; #print $c->as_string; - -$req = HTTP::Request->new(GET => "ftp://ftp.activestate.com/"); +$req = HTTP::Request->new( GET => "ftp://ftp.activestate.com/" ); $c->add_cookie_header($req); -ok(!$req->header("Cookie")); +ok( !$req->header("Cookie") ); -$req = HTTP::Request->new(GET => "file:/etc/motd"); +$req = HTTP::Request->new( GET => "file:/etc/motd" ); $c->add_cookie_header($req); -ok(!$req->header("Cookie")); +ok( !$req->header("Cookie") ); -$req = HTTP::Request->new(GET => "mailto:gisle\@aas.no"); +$req = HTTP::Request->new( GET => "mailto:gisle\@aas.no" ); $c->add_cookie_header($req); -ok(!$req->header("Cookie")); - +ok( !$req->header("Cookie") ); # Test cookie called 'expires' -$c = HTTP::Cookies->new; -$req = HTTP::Request->new("GET" => "http://example.com"); -$res = HTTP::Response->new(200, "OK"); +$c = HTTP::Cookies->new; +$req = HTTP::Request->new( "GET" => "http://example.com" ); +$res = HTTP::Response->new( 200, "OK" ); $res->request($req); -$res->header("Set-Cookie" => "Expires=10101"); +$res->header( "Set-Cookie" => "Expires=10101" ); $c->extract_cookies($res); + #print $c->as_string; -is($c->as_string, <<'EOT'); +is( $c->as_string, <<'EOT' ); Set-Cookie3: Expires=10101; path="/"; domain=example.com; discard; version=0 EOT # Test empty cookie header [RT#29401] $c = HTTP::Cookies->new; -$res->header("Set-Cookie" => ["CUSTOMER=WILE_E_COYOTE; path=/;", ""]); +$res->header( "Set-Cookie" => [ "CUSTOMER=WILE_E_COYOTE; path=/;", "" ] ); + #print $res->as_string; $c->extract_cookies($res); + #print $c->as_string; -is($c->as_string, <<'EOT'); +is( $c->as_string, <<'EOT' ); Set-Cookie3: CUSTOMER=WILE_E_COYOTE; path="/"; domain=example.com; path_spec; discard; version=0 EOT # Test empty cookie part [RT#38480] $c = HTTP::Cookies->new; -$res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE;;path=/;"); +$res->header( "Set-Cookie" => "CUSTOMER=WILE_E_COYOTE;;path=/;" ); + #print $res->as_string; $c->extract_cookies($res); + #print $c->as_string; -is($c->as_string, <<'EOT'); +is( $c->as_string, <<'EOT' ); Set-Cookie3: CUSTOMER=WILE_E_COYOTE; path="/"; domain=example.com; path_spec; discard; version=0 EOT # Test Set-Cookie with version set $c = HTTP::Cookies->new; -$res->header("Set-Cookie" => "foo=\"bar\";version=1"); +$res->header( "Set-Cookie" => "foo=\"bar\";version=1" ); + #print $res->as_string; $c->extract_cookies($res); + #print $c->as_string; -$req = HTTP::Request->new(GET => "http://www.example.com/foo"); +$req = HTTP::Request->new( GET => "http://www.example.com/foo" ); $c->add_cookie_header($req); + #print $req->as_string; -is($req->header("Cookie"), "foo=bar"); +is( $req->header("Cookie"), "foo=bar" ); # Test cookies that expire far into the future [RT#50147] $c = HTTP::Cookies->new; -$res->header("Set-Cookie", "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL; expires=Mon, 03-Oct-2211 15:18:10 GMT; path=/; domain=.example.com"); -$res->push_header("Set-Cookie", "expired1=1; expires=Mon, 03-Oct-2001 15:18:10 GMT; path=/; domain=.example.com"); -$res->push_header("Set-Cookie", "expired2=1; expires=Fri Jan 1 00:00:00 GMT 1970; path=/; domain=.example.com"); -$res->push_header("Set-Cookie", "expired3=1; expires=Fri Jan 1 00:00:01 GMT 1970; path=/; domain=.example.com"); -$res->push_header("Set-Cookie", "expired4=1; expires=Thu Dec 31 23:59:59 GMT 1969; path=/; domain=.example.com"); -$res->push_header("Set-Cookie", "expired5=1; expires=Fri Feb 2 00:00:00 GMT 1950; path=/; domain=.example.com"); +$res->header( + "Set-Cookie", + "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL; expires=Mon, 03-Oct-2211 15:18:10 GMT; path=/; domain=.example.com" +); +$res->push_header( + "Set-Cookie", + "expired1=1; expires=Mon, 03-Oct-2001 15:18:10 GMT; path=/; domain=.example.com" +); +$res->push_header( + "Set-Cookie", + "expired2=1; expires=Fri Jan 1 00:00:00 GMT 1970; path=/; domain=.example.com" +); +$res->push_header( + "Set-Cookie", + "expired3=1; expires=Fri Jan 1 00:00:01 GMT 1970; path=/; domain=.example.com" +); +$res->push_header( + "Set-Cookie", + "expired4=1; expires=Thu Dec 31 23:59:59 GMT 1969; path=/; domain=.example.com" +); +$res->push_header( + "Set-Cookie", + "expired5=1; expires=Fri Feb 2 00:00:00 GMT 1950; path=/; domain=.example.com" +); $c->extract_cookies($res); + #print $res->as_string; #print "---\n"; #print $c->as_string; -$req = HTTP::Request->new(GET => "http://www.example.com/foo"); +$req = HTTP::Request->new( GET => "http://www.example.com/foo" ); $c->add_cookie_header($req); + #print $req->as_string; -is($req->header("Cookie"), "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL"); +is( + $req->header("Cookie"), + "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL" +); $c->clear_temporary_cookies; -$req = HTTP::Request->new(GET => "http://www.example.com/foo"); +$req = HTTP::Request->new( GET => "http://www.example.com/foo" ); $c->add_cookie_header($req); + #print $req->as_string; -is($req->header("Cookie"), "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL"); +is( + $req->header("Cookie"), + "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL" +); # Test merging of cookies $c = HTTP::Cookies->new; -$res->header("Set-Cookie", "foo=1; path=/"); +$res->header( "Set-Cookie", "foo=1; path=/" ); $c->extract_cookies($res); -$req = HTTP::Request->new(GET => "http://www.example.com/foo"); -$req->header("Cookie", "x=bcd"); +$req = HTTP::Request->new( GET => "http://www.example.com/foo" ); +$req->header( "Cookie", "x=bcd" ); $c->add_cookie_header($req); -is($req->header("Cookie"), "x=bcd; foo=1"); +is( $req->header("Cookie"), "x=bcd; foo=1" ); $c->add_cookie_header($req); -is($req->header("Cookie"), "x=bcd; foo=1; foo=1"); +is( $req->header("Cookie"), "x=bcd; foo=1; foo=1" ); + #print $req->as_string; # Test get_cookies $c = HTTP::Cookies->new; -$res->header("Set-Cookie", "foo=42"); +$res->header( "Set-Cookie", "foo=42" ); $c->extract_cookies($res); -is($c->get_cookies("example.com")->{foo}, 42); -is($c->get_cookies("example.com", "foo"), 42); -is($c->get_cookies("example.com", "bar"), undef); -is($c->get_cookies("http://example.com", "foo"), 42); -is($c->get_cookies("https://example.com", "foo"), 42); -is($c->get_cookies(URI->new("https://example.com"), "foo"), 42); -is($c->get_cookies("foo.example.com", "foo"), 42); -is($c->get_cookies("example.org", "foo"), undef); - -my @a = $c->get_cookies("example.com", "bar", "foo"); -is_deeply(\@a, [undef, 42]); +is( $c->get_cookies("example.com")->{foo}, 42 ); +is( $c->get_cookies( "example.com", "foo" ), 42 ); +is( $c->get_cookies( "example.com", "bar" ), undef ); +is( $c->get_cookies( "http://example.com", "foo" ), 42 ); +is( $c->get_cookies( "https://example.com", "foo" ), 42 ); +is( $c->get_cookies( URI->new("https://example.com"), "foo" ), 42 ); +is( $c->get_cookies( "foo.example.com", "foo" ), 42 ); +is( $c->get_cookies( "example.org", "foo" ), undef ); + +my @a = $c->get_cookies( "example.com", "bar", "foo" ); +is_deeply( \@a, [ undef, 42 ] ); # Test ignore_discard argument of save() $c = HTTP::Cookies->new( ignore_discard => 0 ); -interact($c, 'http://example.com/', 'foo=bar; Discard;'); +interact( $c, 'http://example.com/', 'foo=bar; Discard;' ); $old = $c->as_string; $c->save( file => $file, ignore_discard => 1 ); undef $c; @@ -710,14 +805,16 @@ $c = HTTP::Cookies->new( ignore_discard => 0 ); $c->load($file); unlink($file) || warn "Can't unlink $file: $!"; -is($c->as_string, $old); +is( $c->as_string, $old ); -$c = HTTP::Cookies::Netscape->new( ignore_discard => 0 ); -$req = HTTP::Request->new(GET => "http://1.1.1.1/"); -$req->header("Host", "www.acme.com:80"); -$res = HTTP::Response->new(200, "OK"); +$c = HTTP::Cookies::Netscape->new( ignore_discard => 0 ); +$req = HTTP::Request->new( GET => "http://1.1.1.1/" ); +$req->header( "Host", "www.acme.com:80" ); +$res = HTTP::Response->new( 200, "OK" ); $res->request($req); -$res->header("Set-Cookie" => "foo=bar; path=/; discard; expires=Wednesday, 09-Nov-$year_plus_one 23:12:40 GMT"); +$res->header( "Set-Cookie" => + "foo=bar; path=/; discard; expires=Wednesday, 09-Nov-$year_plus_one 23:12:40 GMT" +); $c->extract_cookies($res); $old = $c->as_string; $c->save( file => $file, ignore_discard => 1 ); @@ -725,46 +822,43 @@ undef $c; $c = HTTP::Cookies::Netscape->new( ignore_discard => 0 ); $c->load($file); -$req = HTTP::Request->new(GET => "http://www.acme.com/foo/bar"); +$req = HTTP::Request->new( GET => "http://www.acme.com/foo/bar" ); $c->add_cookie_header($req); $h = $req->header("Cookie"); -like($h, qr/foo=bar/); +like( $h, qr/foo=bar/ ); unlink($file) || warn "Can't unlink $file: $!"; # Test discard isn't set when max-age is set -$c = HTTP::Cookies->new; -$req = HTTP::Request->new("GET" => "http://example.com"); -$res = HTTP::Response->new(200, "OK"); +$c = HTTP::Cookies->new; +$req = HTTP::Request->new( "GET" => "http://example.com" ); +$res = HTTP::Response->new( 200, "OK" ); $res->request($req); -$res->header("Set-Cookie" => "foo=bar; max-age=1337"); +$res->header( "Set-Cookie" => "foo=bar; max-age=1337" ); $c->extract_cookies($res); + #print $c->as_string; -is($c->as_string, <<'EOT'); +is( $c->as_string, <<'EOT' ); Set-Cookie3: foo=bar; path="/"; domain=example.com; version=0 EOT - - #------------------------------------------------------------------- -sub interact -{ - my $c = shift; +sub interact { + my $c = shift; my $url = shift; - my $req = HTTP::Request->new(POST => $url); + my $req = HTTP::Request->new( POST => $url ); $c->add_cookie_header($req); my $cookie = $req->header("Cookie"); - my $res = HTTP::Response->new(200, "OK"); + my $res = HTTP::Response->new( 200, "OK" ); $res->request($req); - for (@_) { $res->push_header("Set-Cookie2" => $_) } + for (@_) { $res->push_header( "Set-Cookie2" => $_ ) } $c->extract_cookies($res); return $cookie; } -sub count_cookies -{ - my $c = shift; +sub count_cookies { + my $c = shift; my $no = 0; - $c->scan(sub { $no++ }); + $c->scan( sub { $no++ } ); $no; } diff --git a/t/issue26.t b/t/issue26.t index 40a1120d..97435d9f 100644 --- a/t/issue26.t +++ b/t/issue26.t @@ -1,22 +1,24 @@ use strict; use Test::More; -use HTTP::Cookies (); +use HTTP::Cookies (); use HTTP::Response (); -use HTTP::Request (); +use HTTP::Request (); -my $CRLF="\015\012"; +my $CRLF = "\015\012"; my $cookie_jar = HTTP::Cookies->new(); -my $request = HTTP::Request->new(GET => 'http://www.en.com/'); +my $request = HTTP::Request->new( GET => 'http://www.en.com/' ); -my $response = HTTP::Response->parse - ("HTTP/1.1 302 Moved" . $CRLF . "Set-Cookie: expires=10101$CRLF$CRLF"); +my $response = HTTP::Response->parse( + "HTTP/1.1 302 Moved" . $CRLF . "Set-Cookie: expires=10101$CRLF$CRLF" ); $response->request($request); $cookie_jar->extract_cookies($response); -is $cookie_jar->as_string(), 'Set-Cookie3: expires=10101; path="/"; domain=www.en.com; discard; version=0' . "\n"; +is $cookie_jar->as_string(), + 'Set-Cookie3: expires=10101; path="/"; domain=www.en.com; discard; version=0' + . "\n"; done_testing; diff --git a/t/issue32.t b/t/issue32.t index 040a01b4..dc6f58df 100644 --- a/t/issue32.t +++ b/t/issue32.t @@ -2,25 +2,37 @@ use strict; use warnings; use Test::More; -use HTTP::Cookies (); -use HTTP::Request (); +use HTTP::Cookies (); +use HTTP::Request (); use HTTP::Response (); -my $nextyear = 1901+(gmtime())[5]; +my $nextyear = 1901 + ( gmtime() )[5]; -my $req = HTTP::Request->new(GET => "http://example.com"); -my $resp = HTTP::Response->new(200, 'OK', ['Set-Cookie', q!a="b;c;\\"d"; expires=Fri, 06-Nov-! . $nextyear . " 08:58:34 GMT; domain=example.com; path=/"]); +my $req = HTTP::Request->new( GET => "http://example.com" ); +my $resp = HTTP::Response->new( + 200, 'OK', + [ + 'Set-Cookie', + q!a="b;c;\\"d"; expires=Fri, 06-Nov-! + . $nextyear + . " 08:58:34 GMT; domain=example.com; path=/" + ] +); $resp->request($req); my $c = HTTP::Cookies->new; $c->extract_cookies($resp); -is $c->as_string, 'Set-Cookie3: a="b;c;\"d"; path="/"; domain=example.com; path_spec; expires="' . $nextyear . '-11-06 08:58:34Z"; version=0' . "\n"; +is $c->as_string, + 'Set-Cookie3: a="b;c;\"d"; path="/"; domain=example.com; path_spec; expires="' + . $nextyear + . '-11-06 08:58:34Z"; version=0' . "\n"; # test the implementation of the split function in isolation. # should probably name the function better too. my $simple = 'b;c;d'; is_deeply HTTP::Cookies::_split_text($simple), [qw/b c d/], "Parse $simple"; my $complex = '"b;c;\\"d";blah=32;foo="/"'; -is_deeply HTTP::Cookies::_split_text($complex), ['b;c;"d','blah=32','foo=/'], "Parse $complex"; +is_deeply HTTP::Cookies::_split_text($complex), + [ 'b;c;"d', 'blah=32', 'foo=/' ], "Parse $complex"; done_testing; diff --git a/t/publicsuffix.t b/t/publicsuffix.t index 7f5df829..ee99df6f 100644 --- a/t/publicsuffix.t +++ b/t/publicsuffix.t @@ -5,21 +5,20 @@ use warnings; use Test::More; -use HTTP::Cookies (); -use HTTP::Date (); -use HTTP::Request (); +use HTTP::Cookies (); +use HTTP::Date (); +use HTTP::Request (); use HTTP::Response (); - my $expiry_string = HTTP::Date::time2str( time + 86_400 ); -my $jar = HTTP::Cookies->new; +my $jar = HTTP::Cookies->new; { local $TODO = 'Unexpected cookies stored'; my $res = HTTP::Response->new( 200, 'OK' ); my $req = request_for('www.exceptone.co.uk'); $res->header( 'Set-Cookie' => - "security=fail; Domain=.co.uk; Expires=${expiry_string}" ); + "security=fail; Domain=.co.uk; Expires=${expiry_string}" ); $res->request($req); $jar->extract_cookies($res); is count_cookies_for('.co.uk'), 0, 'No .co.uk cookies stored in the jar'; @@ -43,7 +42,7 @@ my $jar = HTTP::Cookies->new; my $res = HTTP::Response->new( 200, 'OK' ); my $req = request_for('www.example.com'); $res->header( 'Set-Cookie' => - "dotcom=pwned; Domain=.com; Expires=${expiry_string}" ); + "dotcom=pwned; Domain=.com; Expires=${expiry_string}" ); $res->request($req); $jar->extract_cookies($res); is count_cookies_for('.com'), 0, 'No .com cookies stored in the jar'; @@ -56,17 +55,16 @@ my $jar = HTTP::Cookies->new; is $req->header('Cookie'), undef, 'No cookies sent to www.google.com'; } - sub count_cookies_for { - my $host = shift; + my $host = shift; my $count = 0; - $jar->scan( sub { $_[4] eq $host && $count++ }); + $jar->scan( sub { $_[4] eq $host && $count++ } ); return $count; } sub request_for { my $host = shift; - my $req = HTTP::Request->new( GET => "http://${host}/"); + my $req = HTTP::Request->new( GET => "http://${host}/" ); $req->header( Host => $host ); return $req; }