1N/A#!perl -w
1N/A
1N/Ause strict;
1N/A
1N/A# to have a consistent baseline, we nail the current time
1N/A# to 100 seconds after the epoch
1N/ABEGIN {
1N/A *CORE::GLOBAL::time = sub { 100 };
1N/A}
1N/A
1N/Ause Test::More 'no_plan';
1N/Ause CGI::Util qw(escape unescape);
1N/Ause POSIX qw(strftime);
1N/Ause CGI::Cookie;
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# make sure module loaded
1N/A#-----------------------------------------------------------------------------
1N/A
1N/Amy @test_cookie = (
1N/A # including leading and trailing whitespace in first cookie
1N/A ' foo=123 ; bar=qwerty; baz=wibble; qux=a1',
1N/A 'foo=123; bar=qwerty; baz=wibble;',
1N/A 'foo=vixen; bar=cow; baz=bitch; qux=politician',
1N/A 'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27',
1N/A );
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test parse
1N/A#-----------------------------------------------------------------------------
1N/A
1N/A{
1N/A my $result = CGI::Cookie->parse($test_cookie[0]);
1N/A is(ref($result), 'HASH', "Hash ref returned in scalar context");
1N/A
1N/A my @result = CGI::Cookie->parse($test_cookie[0]);
1N/A is(@result, 8, "returns correct number of fields");
1N/A
1N/A @result = CGI::Cookie->parse($test_cookie[1]);
1N/A is(@result, 6, "returns correct number of fields");
1N/A
1N/A my %result = CGI::Cookie->parse($test_cookie[0]);
1N/A is($result{foo}->value, '123', "cookie foo is correct");
1N/A is($result{bar}->value, 'qwerty', "cookie bar is correct");
1N/A is($result{baz}->value, 'wibble', "cookie baz is correct");
1N/A is($result{qux}->value, 'a1', "cookie qux is correct");
1N/A
1N/A my @array = CGI::Cookie->parse('');
1N/A my $scalar = CGI::Cookie->parse('');
1N/A is_deeply(\@array, [], " parse('') returns an empty array in list context (undocumented)");
1N/A is_deeply($scalar, {}, " parse('') returns an empty hashref in scalar context (undocumented)");
1N/A
1N/A @array = CGI::Cookie->parse(undef);
1N/A $scalar = CGI::Cookie->parse(undef);
1N/A is_deeply(\@array, [], " parse(undef) returns an empty array in list context (undocumented)");
1N/A is_deeply($scalar, {}, " parse(undef) returns an empty hashref in scalar context (undocumented)");
1N/A}
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test fetch
1N/A#-----------------------------------------------------------------------------
1N/A
1N/A{
1N/A # make sure there are no cookies in the environment
1N/A delete $ENV{HTTP_COOKIE};
1N/A delete $ENV{COOKIE};
1N/A
1N/A my %result = CGI::Cookie->fetch();
1N/A ok(keys %result == 0, "No cookies in environment, returns empty list");
1N/A
1N/A # now set a cookie in the environment and try again
1N/A $ENV{HTTP_COOKIE} = $test_cookie[2];
1N/A %result = CGI::Cookie->fetch();
1N/A ok(eq_set([keys %result], [qw(foo bar baz qux)]),
1N/A "expected cookies extracted");
1N/A
1N/A is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
1N/A is($result{foo}->value, 'vixen', "cookie foo is correct");
1N/A is($result{bar}->value, 'cow', "cookie bar is correct");
1N/A is($result{baz}->value, 'bitch', "cookie baz is correct");
1N/A is($result{qux}->value, 'politician', "cookie qux is correct");
1N/A
1N/A # Delete that and make sure it goes away
1N/A delete $ENV{HTTP_COOKIE};
1N/A %result = CGI::Cookie->fetch();
1N/A ok(keys %result == 0, "No cookies in environment, returns empty list");
1N/A
1N/A # try another cookie in the other environment variable thats supposed to work
1N/A $ENV{COOKIE} = $test_cookie[3];
1N/A %result = CGI::Cookie->fetch();
1N/A ok(eq_set([keys %result], [qw(foo bar baz qux)]),
1N/A "expected cookies extracted");
1N/A
1N/A is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
1N/A is($result{foo}->value, 'a phrase', "cookie foo is correct");
1N/A is($result{bar}->value, 'yes, a phrase', "cookie bar is correct");
1N/A is($result{baz}->value, '^wibble', "cookie baz is correct");
1N/A is($result{qux}->value, "'", "cookie qux is correct");
1N/A}
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test raw_fetch
1N/A#-----------------------------------------------------------------------------
1N/A
1N/A{
1N/A # make sure there are no cookies in the environment
1N/A delete $ENV{HTTP_COOKIE};
1N/A delete $ENV{COOKIE};
1N/A
1N/A my %result = CGI::Cookie->raw_fetch();
1N/A ok(keys %result == 0, "No cookies in environment, returns empty list");
1N/A
1N/A # now set a cookie in the environment and try again
1N/A $ENV{HTTP_COOKIE} = $test_cookie[2];
1N/A %result = CGI::Cookie->raw_fetch();
1N/A ok(eq_set([keys %result], [qw(foo bar baz qux)]),
1N/A "expected cookies extracted");
1N/A
1N/A is(ref($result{foo}), '', 'Plain scalar returned');
1N/A is($result{foo}, 'vixen', "cookie foo is correct");
1N/A is($result{bar}, 'cow', "cookie bar is correct");
1N/A is($result{baz}, 'bitch', "cookie baz is correct");
1N/A is($result{qux}, 'politician', "cookie qux is correct");
1N/A
1N/A # Delete that and make sure it goes away
1N/A delete $ENV{HTTP_COOKIE};
1N/A %result = CGI::Cookie->raw_fetch();
1N/A ok(keys %result == 0, "No cookies in environment, returns empty list");
1N/A
1N/A # try another cookie in the other environment variable thats supposed to work
1N/A $ENV{COOKIE} = $test_cookie[3];
1N/A %result = CGI::Cookie->raw_fetch();
1N/A ok(eq_set([keys %result], [qw(foo bar baz qux)]),
1N/A "expected cookies extracted");
1N/A
1N/A is(ref($result{foo}), '', 'Plain scalar returned');
1N/A is($result{foo}, 'a%20phrase', "cookie foo is correct");
1N/A is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct");
1N/A is($result{baz}, '%5Ewibble', "cookie baz is correct");
1N/A is($result{qux}, '%27', "cookie qux is correct");
1N/A
1N/A $ENV{COOKIE} = '$Version=1; foo; $Path="/test"';
1N/A %result = CGI::Cookie->raw_fetch();
1N/A is($result{foo}, '', 'no value translates to empty string');
1N/A}
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test new
1N/A#-----------------------------------------------------------------------------
1N/A
1N/A{
1N/A # Try new with full information provided
1N/A my $c = CGI::Cookie->new(-name => 'foo',
1N/A -value => 'bar',
1N/A -expires => '+3M',
1N/A -domain => '.capricorn.com',
1N/A -path => '/cgi-bin/database',
1N/A -secure => 1,
1N/A -httponly=> 1
1N/A );
1N/A is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
1N/A is($c->name , 'foo', 'name is correct');
1N/A is($c->value , 'bar', 'value is correct');
1N/A like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires in correct format');
1N/A is($c->domain , '.capricorn.com', 'domain is correct');
1N/A is($c->path , '/cgi-bin/database', 'path is correct');
1N/A ok($c->secure , 'secure attribute is set');
1N/A ok( $c->httponly, 'httponly attribute is set' );
1N/A
1N/A # now try it with the only two manditory values (should also set the default path)
1N/A $c = CGI::Cookie->new(-name => 'baz',
1N/A -value => 'qux',
1N/A );
1N/A is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
1N/A is($c->name , 'baz', 'name is correct');
1N/A is($c->value , 'qux', 'value is correct');
1N/A ok(!defined $c->expires, 'expires is not set');
1N/A ok(!defined $c->domain , 'domain attributeis not set');
1N/A is($c->path, '/', 'path atribute is set to default');
1N/A ok(!defined $c->secure , 'secure attribute is set');
1N/A ok( !defined $c->httponly, 'httponly attribute is not set' );
1N/A
1N/A# I'm really not happy about the restults of this section. You pass
1N/A# the new method invalid arguments and it just merilly creates a
1N/A# broken object :-)
1N/A# I've commented them out because they currently pass but I don't
1N/A# think they should. I think this is testing broken behaviour :-(
1N/A
1N/A# # This shouldn't work
1N/A# $c = CGI::Cookie->new(-name => 'baz' );
1N/A#
1N/A# is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
1N/A# is($c->name , 'baz', 'name is correct');
1N/A# ok(!defined $c->value, "Value is undefined ");
1N/A# ok(!defined $c->expires, 'expires is not set');
1N/A# ok(!defined $c->domain , 'domain attributeis not set');
1N/A# is($c->path , '/', 'path atribute is set to default');
1N/A# ok(!defined $c->secure , 'secure attribute is set');
1N/A
1N/A}
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test as_string
1N/A#-----------------------------------------------------------------------------
1N/A
1N/A{
1N/A my $c = CGI::Cookie->new(-name => 'Jam',
1N/A -value => 'Hamster',
1N/A -expires => '+3M',
1N/A -domain => '.pie-shop.com',
1N/A -path => '/',
1N/A -secure => 1,
1N/A -httponly=> 1
1N/A );
1N/A
1N/A my $name = $c->name;
1N/A like($c->as_string, "/$name/", "Stringified cookie contains name");
1N/A
1N/A my $value = $c->value;
1N/A like($c->as_string, "/$value/", "Stringified cookie contains value");
1N/A
1N/A my $expires = $c->expires;
1N/A like($c->as_string, "/$expires/", "Stringified cookie contains expires");
1N/A
1N/A my $domain = $c->domain;
1N/A like($c->as_string, "/$domain/", "Stringified cookie contains domain");
1N/A
1N/A my $path = $c->path;
1N/A like($c->as_string, "/$path/", "Stringified cookie contains path");
1N/A
1N/A like($c->as_string, '/secure/', "Stringified cookie contains secure");
1N/A
1N/A like( $c->as_string, '/HttpOnly/',
1N/A "Stringified cookie contains HttpOnly" );
1N/A
1N/A $c = CGI::Cookie->new(-name => 'Hamster-Jam',
1N/A -value => 'Tulip',
1N/A );
1N/A
1N/A $name = $c->name;
1N/A like($c->as_string, "/$name/", "Stringified cookie contains name");
1N/A
1N/A $value = $c->value;
1N/A like($c->as_string, "/$value/", "Stringified cookie contains value");
1N/A
1N/A ok($c->as_string !~ /expires/, "Stringified cookie has no expires field");
1N/A
1N/A ok($c->as_string !~ /domain/, "Stringified cookie has no domain field");
1N/A
1N/A $path = $c->path;
1N/A like($c->as_string, "/$path/", "Stringified cookie contains path");
1N/A
1N/A ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure");
1N/A
1N/A ok( $c->as_string !~ /HttpOnly/,
1N/A "Stringified cookie does not contain HttpOnly" );
1N/A}
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test compare
1N/A#-----------------------------------------------------------------------------
1N/A
1N/A{
1N/A my $c1 = CGI::Cookie->new(-name => 'Jam',
1N/A -value => 'Hamster',
1N/A -expires => '+3M',
1N/A -domain => '.pie-shop.com',
1N/A -path => '/',
1N/A -secure => 1
1N/A );
1N/A
1N/A # have to use $c1->expires because the time will occasionally be
1N/A # different between the two creates causing spurious failures.
1N/A my $c2 = CGI::Cookie->new(-name => 'Jam',
1N/A -value => 'Hamster',
1N/A -expires => $c1->expires,
1N/A -domain => '.pie-shop.com',
1N/A -path => '/',
1N/A -secure => 1
1N/A );
1N/A
1N/A # This looks titally whacked, but it does the -1, 0, 1 comparison
1N/A # thing so 0 means they match
1N/A is($c1->compare("$c1"), 0, "Cookies are identical");
1N/A is( "$c1", "$c2", "Cookies are identical");
1N/A
1N/A $c1 = CGI::Cookie->new(-name => 'Jam',
1N/A -value => 'Hamster',
1N/A -domain => '.foo.bar.com'
1N/A );
1N/A
1N/A # have to use $c1->expires because the time will occasionally be
1N/A # different between the two creates causing spurious failures.
1N/A $c2 = CGI::Cookie->new(-name => 'Jam',
1N/A -value => 'Hamster',
1N/A );
1N/A
1N/A # This looks titally whacked, but it does the -1, 0, 1 comparison
1N/A # thing so 0 (i.e. false) means they match
1N/A is($c1->compare("$c1"), 0, "Cookies are identical");
1N/A ok($c1->compare("$c2"), "Cookies are not identical");
1N/A
1N/A $c2->domain('.foo.bar.com');
1N/A is($c1->compare("$c2"), 0, "Cookies are identical");
1N/A}
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test name, value, domain, secure, expires and path
1N/A#-----------------------------------------------------------------------------
1N/A
1N/A{
1N/A my $c = CGI::Cookie->new(-name => 'Jam',
1N/A -value => 'Hamster',
1N/A -expires => '+3M',
1N/A -domain => '.pie-shop.com',
1N/A -path => '/',
1N/A -secure => 1
1N/A );
1N/A
1N/A is($c->name, 'Jam', 'name is correct');
1N/A is($c->name('Clash'), 'Clash', 'name is set correctly');
1N/A is($c->name, 'Clash', 'name now returns updated value');
1N/A
1N/A # this is insane! it returns a simple scalar but can't accept one as
1N/A # an argument, you have to give it an arrary ref. It's totally
1N/A # inconsitent with these other methods :-(
1N/A is($c->value, 'Hamster', 'value is correct');
1N/A is($c->value(['Gerbil']), 'Gerbil', 'value is set correctly');
1N/A is($c->value, 'Gerbil', 'value now returns updated value');
1N/A
1N/A my $exp = $c->expires;
1N/A like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is correct');
1N/A like($c->expires('+12h'), '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is set correctly');
1N/A like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires now returns updated value');
1N/A isnt($c->expires, $exp, "Expiry time has changed");
1N/A
1N/A is($c->domain, '.pie-shop.com', 'domain is correct');
1N/A is($c->domain('.wibble.co.uk'), '.wibble.co.uk', 'domain is set correctly');
1N/A is($c->domain, '.wibble.co.uk', 'domain now returns updated value');
1N/A
1N/A is($c->path, '/', 'path is correct');
1N/A is($c->path('/basket/'), '/basket/', 'path is set correctly');
1N/A is($c->path, '/basket/', 'path now returns updated value');
1N/A
1N/A ok($c->secure, 'secure attribute is set');
1N/A ok(!$c->secure(0), 'secure attribute is cleared');
1N/A ok(!$c->secure, 'secure attribute is cleared');
1N/A}
1N/A
1N/A#----------------------------------------------------------------------------
1N/A# Max-age
1N/A#----------------------------------------------------------------------------
1N/A
1N/AMAX_AGE: {
1N/A my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',);
1N/A is $cookie->expires, 'Thu, 01-Jan-1970 00:01:40 GMT';
1N/A is $cookie->max_age => undef, 'max-age is undefined when setting expires';
1N/A
1N/A $cookie = CGI::Cookie->new( -name=>'a', 'value'=>'b' );
1N/A $cookie->max_age( '+4d' );
1N/A
1N/A is $cookie->expires, undef, 'expires is undef when setting max_age';
1N/A is $cookie->max_age => 4*24*60*60, 'setting via max-age';
1N/A
1N/A $cookie->max_age( '113' );
1N/A is $cookie->max_age => 13, 'max_age(num) as delta';
1N/A}
1N/A
1N/A
1N/A#----------------------------------------------------------------------------
1N/A# bake
1N/A#----------------------------------------------------------------------------
1N/A
1N/ABAKE: {
1N/A my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',);
1N/A # Older Perl may be confused while evaluating test results with cookie
1N/A # dump. To avoid this we will make sure that cookie is print on STDERR
1N/A # and not STDOUT.
1N/A my $oldfh = select(STDERR);
1N/A eval { $cookie->bake };
1N/A select($oldfh);
1N/A is($@,'', "calling bake() without mod_perl should survive");
1N/A}
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Apache2?::Cookie compatibility.
1N/A#-----------------------------------------------------------------------------
1N/AAPACHEREQ: {
1N/A my $r = Apache::Faker->new;
1N/A isa_ok $r, 'Apache';
1N/A ok my $c = CGI::Cookie->new(
1N/A $r,
1N/A -name => 'Foo',
1N/A -value => 'Bar',
1N/A ), 'Pass an Apache object to the CGI::Cookie constructor';
1N/A isa_ok $c, 'CGI::Cookie';
1N/A ok $c->bake($r), 'Bake the cookie';
1N/A ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
1N/A 'bake() should call headers_out->set()';
1N/A
1N/A $r = Apache2::Faker->new;
1N/A isa_ok $r, 'Apache2::RequestReq';
1N/A ok $c = CGI::Cookie->new(
1N/A $r,
1N/A -name => 'Foo',
1N/A -value => 'Bar',
1N/A ), 'Pass an Apache::RequestReq object to the CGI::Cookie constructor';
1N/A isa_ok $c, 'CGI::Cookie';
1N/A ok $c->bake($r), 'Bake the cookie';
1N/A ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
1N/A 'bake() should call headers_out->set()';
1N/A}
1N/A
1N/A
1N/Apackage Apache::Faker;
1N/Asub new { bless {}, shift }
1N/Asub isa {
1N/A my ($self, $pkg) = @_;
1N/A return $pkg eq 'Apache';
1N/A}
1N/Asub headers_out { shift }
1N/Asub add { shift->{check} = \@_; }
1N/A
1N/Apackage Apache2::Faker;
1N/Asub new { bless {}, shift }
1N/Asub isa {
1N/A my ($self, $pkg) = @_;
1N/A return $pkg eq 'Apache2::RequestReq';
1N/A}
1N/Asub headers_out { shift }
1N/Asub add { shift->{check} = \@_; }