| Subject: | extract_cookie() confused by undefined values |
It appears that extract_cookies() (or more specifically the private
function _get_cookies()) is confused when the cookie parameters are
undefined.
Believe that the problem is this assignment:
@cookie{qw(version key value path domain port path domain port path_spec
secure expires discard hash)} = @_;
(which also duplicates the path and domain parameters).
This causes the subsequent hash ref to have the wrong values associated
with some of the keys.
I've attached a patch containing a proposed fix, and a test script that
illustrates the problem when run before/after the fix.
| Subject: | Response.pm.patch |
--- lib/Test/HTTP/Response.pm 2011-03-22 20:31:53.000000000 +0000
+++ lib/Test/HTTP/Response.pm.new 2011-10-11 13:45:51.857809359 +0100
@@ -40,6 +40,8 @@ use HTTP::Request;
use HTTP::Response;
use HTTP::Cookies;
+use List::MoreUtils qw(mesh);
+
use base qw( Exporter Test::Builder::Module);
our @EXPORT = qw(status_matches status_ok status_redirect status_not_found status_error
@@ -301,11 +303,16 @@ sub _get_cookies {
unless ($response->request) {
$response->request(HTTP::Request->new(GET => 'http://www.example.com/'));
}
+
+ my @params =
+ qw(version key value path domain port path_spec secure
+ expires discard hash);
+
my $cookie_jar = HTTP::Cookies->new;
$cookie_jar->extract_cookies($response);
$cookie_jar->scan( sub {
my %cookie = ();
- @cookie{qw(version key value path domain port path domain port path_spec secure expires discard hash)} = @_;
+ %cookie = mesh( @params, @_ );
$cookies->{"$response"}{$cookie{key}} = \%cookie;
}
);
| Subject: | 04_cookies.t |
use strict;
use HTTP::Response;
use HTTP::Message;
use CGI::Cookie;
use DateTime;
use Test::Deep;
use Test::More;
use Test::HTTP::Response;
my $t = DateTime->now;
my $exp = $t->add(hours => 1)->strftime( '%A, %d-%b-%Y %T %Z' );
{
# Create new cookies, headers, etc
my $cookie = CGI::Cookie->new( -name=>'ID'
, -value=>123456
, -expires=>$exp );
my $headers = ['set_cookie' => $cookie->as_string, 'content_type', 'Text/HTML'];
my $message = HTTP::Message->new( $headers, '<HTML><BODY><h1>Hello World</h1></BODY></HTML>');
my $response = HTTP::Response->new( 200, $message, $message->headers );
#
# check matching cookie(s) found in response
cookie_matches($response, { key => 'ID' },'ID exists ok');
cookie_matches($response, { key => 'ID', value=>"123456" }, 'ID value correct');
# HTTP::Cookie extract_cookies always sets:
# path = '/';
# unless otherwise set.
my $cookies = extract_cookies($response);
my $expected_cookie = {
'domain' => 'www.example.com',
'discard' => undef,
'value' => $cookie->value, #'123456',
'version' => 0,
'path' => $cookie->path, #'/',
'port' => undef,
'key' => 'ID',
'path_spec' => 1,
'expires' => $t->epoch,
'secure' => $cookie->secure, #undef,
};
cmp_deeply( $cookies->{ID}, superhashof( $expected_cookie ) );
}
{
# Create new cookies, headers, etc
my $cookie = CGI::Cookie->new( -name=>'ID'
, -value=>123456 );
my $headers = ['set_cookie' => $cookie->as_string, 'content_type', 'Text/HTML'];
my $message = HTTP::Message->new( $headers, '<HTML><BODY><h1>Hello World</h1></BODY></HTML>');
my $response = HTTP::Response->new( 200, $message, $message->headers );
#
# check matching cookie(s) found in response
cookie_matches($response, { key => 'ID' },'ID exists ok');
cookie_matches($response, { key => 'ID', value=>"123456" }, 'ID value correct');
# HTTP::Cookie extract_cookies always sets:
# path = '/';
# unless otherwise set.
my $cookies = extract_cookies($response);
my $expected_cookie = {
'domain' => 'www.example.com',
'discard' => 1,
'value' => $cookie->value, #'123456',
'version' => 0,
'path' => $cookie->path, #'/',
'port' => undef,
'key' => 'ID',
'path_spec' => 1,
'expires' => undef,
'secure' => $cookie->secure, #undef,
};
cmp_deeply( $cookies->{ID}, superhashof( $expected_cookie ) );
}
done_testing;