diff options
Diffstat (limited to 'cpan/CGI/t/cookie.t')
| -rw-r--r-- | cpan/CGI/t/cookie.t | 162 |
1 files changed, 109 insertions, 53 deletions
diff --git a/cpan/CGI/t/cookie.t b/cpan/CGI/t/cookie.t index f5afc18596..8249f0798e 100644 --- a/cpan/CGI/t/cookie.t +++ b/cpan/CGI/t/cookie.t @@ -1,23 +1,29 @@ -#!/usr/local/bin/perl -w +#!perl -w use strict; -use Test::More tests => 96; +# to have a consistent baseline, we nail the current time +# to 100 seconds after the epoch +BEGIN { + *CORE::GLOBAL::time = sub { 100 }; +} + +use Test::More 'no_plan'; use CGI::Util qw(escape unescape); use POSIX qw(strftime); +use CGI::Cookie; #----------------------------------------------------------------------------- # make sure module loaded #----------------------------------------------------------------------------- -BEGIN {use_ok('CGI::Cookie');} - my @test_cookie = ( - 'foo=123; bar=qwerty; baz=wibble; qux=a1', - 'foo=123; bar=qwerty; baz=wibble;', - 'foo=vixen; bar=cow; baz=bitch; qux=politician', - 'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27', - ); + # including leading and trailing whitespace in first cookie + ' foo=123 ; bar=qwerty; baz=wibble; qux=a1', + 'foo=123; bar=qwerty; baz=wibble;', + 'foo=vixen; bar=cow; baz=bitch; qux=politician', + 'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27', + ); #----------------------------------------------------------------------------- # Test parse @@ -25,23 +31,29 @@ my @test_cookie = ( { my $result = CGI::Cookie->parse($test_cookie[0]); - is(ref($result), 'HASH', "Hash ref returned in scalar context"); my @result = CGI::Cookie->parse($test_cookie[0]); - is(@result, 8, "returns correct number of fields"); @result = CGI::Cookie->parse($test_cookie[1]); - is(@result, 6, "returns correct number of fields"); my %result = CGI::Cookie->parse($test_cookie[0]); - is($result{foo}->value, '123', "cookie foo is correct"); is($result{bar}->value, 'qwerty', "cookie bar is correct"); is($result{baz}->value, 'wibble', "cookie baz is correct"); is($result{qux}->value, 'a1', "cookie qux is correct"); + + my @array = CGI::Cookie->parse(''); + my $scalar = CGI::Cookie->parse(''); + is_deeply(\@array, [], " parse('') returns an empty array in list context (undocumented)"); + is_deeply($scalar, {}, " parse('') returns an empty hashref in scalar context (undocumented)"); + + my @array = CGI::Cookie->parse(undef); + my $scalar = CGI::Cookie->parse(undef); + is_deeply(\@array, [], " parse(undef) returns an empty array in list context (undocumented)"); + is_deeply($scalar, {}, " parse(undef) returns an empty hashref in scalar context (undocumented)"); } #----------------------------------------------------------------------------- @@ -126,6 +138,10 @@ my @test_cookie = ( is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct"); is($result{baz}, '%5Ewibble', "cookie baz is correct"); is($result{qux}, '%27', "cookie qux is correct"); + + $ENV{COOKIE} = '$Version=1; foo; $Path="/test"'; + %result = CGI::Cookie->raw_fetch(); + is($result{foo}, '', 'no value translates to empty string'); } #----------------------------------------------------------------------------- @@ -135,12 +151,13 @@ my @test_cookie = ( { # Try new with full information provided my $c = CGI::Cookie->new(-name => 'foo', - -value => 'bar', - -expires => '+3M', - -domain => '.capricorn.com', - -path => '/cgi-bin/database', - -secure => 1 - ); + -value => 'bar', + -expires => '+3M', + -domain => '.capricorn.com', + -path => '/cgi-bin/database', + -secure => 1, + -httponly=> 1 + ); is(ref($c), 'CGI::Cookie', 'new returns objects of correct type'); is($c->name , 'foo', 'name is correct'); is($c->value , 'bar', 'value is correct'); @@ -148,11 +165,12 @@ my @test_cookie = ( is($c->domain , '.capricorn.com', 'domain is correct'); is($c->path , '/cgi-bin/database', 'path is correct'); ok($c->secure , 'secure attribute is set'); + ok( $c->httponly, 'httponly attribute is set' ); # now try it with the only two manditory values (should also set the default path) $c = CGI::Cookie->new(-name => 'baz', - -value => 'qux', - ); + -value => 'qux', + ); is(ref($c), 'CGI::Cookie', 'new returns objects of correct type'); is($c->name , 'baz', 'name is correct'); is($c->value , 'qux', 'value is correct'); @@ -160,6 +178,7 @@ my @test_cookie = ( ok(!defined $c->domain , 'domain attributeis not set'); is($c->path, '/', 'path atribute is set to default'); ok(!defined $c->secure , 'secure attribute is set'); + ok( !defined $c->httponly, 'httponly attribute is not set' ); # I'm really not happy about the restults of this section. You pass # the new method invalid arguments and it just merilly creates a @@ -186,12 +205,13 @@ my @test_cookie = ( { my $c = CGI::Cookie->new(-name => 'Jam', - -value => 'Hamster', - -expires => '+3M', - -domain => '.pie-shop.com', - -path => '/', - -secure => 1 - ); + -value => 'Hamster', + -expires => '+3M', + -domain => '.pie-shop.com', + -path => '/', + -secure => 1, + -httponly=> 1 + ); my $name = $c->name; like($c->as_string, "/$name/", "Stringified cookie contains name"); @@ -210,9 +230,12 @@ my @test_cookie = ( like($c->as_string, '/secure/', "Stringified cookie contains secure"); + like( $c->as_string, '/HttpOnly/', + "Stringified cookie contains HttpOnly" ); + $c = CGI::Cookie->new(-name => 'Hamster-Jam', - -value => 'Tulip', - ); + -value => 'Tulip', + ); $name = $c->name; like($c->as_string, "/$name/", "Stringified cookie contains name"); @@ -228,6 +251,9 @@ my @test_cookie = ( like($c->as_string, "/$path/", "Stringified cookie contains path"); ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure"); + + ok( $c->as_string !~ /HttpOnly/, + "Stringified cookie does not contain HttpOnly" ); } #----------------------------------------------------------------------------- @@ -236,38 +262,38 @@ my @test_cookie = ( { my $c1 = CGI::Cookie->new(-name => 'Jam', - -value => 'Hamster', - -expires => '+3M', - -domain => '.pie-shop.com', - -path => '/', - -secure => 1 - ); + -value => 'Hamster', + -expires => '+3M', + -domain => '.pie-shop.com', + -path => '/', + -secure => 1 + ); # have to use $c1->expires because the time will occasionally be # different between the two creates causing spurious failures. my $c2 = CGI::Cookie->new(-name => 'Jam', - -value => 'Hamster', - -expires => $c1->expires, - -domain => '.pie-shop.com', - -path => '/', - -secure => 1 - ); + -value => 'Hamster', + -expires => $c1->expires, + -domain => '.pie-shop.com', + -path => '/', + -secure => 1 + ); # This looks titally whacked, but it does the -1, 0, 1 comparison # thing so 0 means they match is($c1->compare("$c1"), 0, "Cookies are identical"); - is($c1->compare("$c2"), 0, "Cookies are identical"); + is( "$c1", "$c2", "Cookies are identical"); $c1 = CGI::Cookie->new(-name => 'Jam', - -value => 'Hamster', - -domain => '.foo.bar.com' - ); + -value => 'Hamster', + -domain => '.foo.bar.com' + ); # have to use $c1->expires because the time will occasionally be # different between the two creates causing spurious failures. $c2 = CGI::Cookie->new(-name => 'Jam', - -value => 'Hamster', - ); + -value => 'Hamster', + ); # This looks titally whacked, but it does the -1, 0, 1 comparison # thing so 0 (i.e. false) means they match @@ -284,12 +310,12 @@ my @test_cookie = ( { my $c = CGI::Cookie->new(-name => 'Jam', - -value => 'Hamster', - -expires => '+3M', - -domain => '.pie-shop.com', - -path => '/', - -secure => 1 - ); + -value => 'Hamster', + -expires => '+3M', + -domain => '.pie-shop.com', + -path => '/', + -secure => 1 + ); is($c->name, 'Jam', 'name is correct'); is($c->name('Clash'), 'Clash', 'name is set correctly'); @@ -321,6 +347,36 @@ my @test_cookie = ( ok(!$c->secure, 'secure attribute is cleared'); } +#---------------------------------------------------------------------------- +# Max-age +#---------------------------------------------------------------------------- + +MAX_AGE: { + my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',); + is $cookie->expires, 'Thu, 01-Jan-1970 00:01:40 GMT'; + is $cookie->max_age => undef, 'max-age is undefined when setting expires'; + + my $cookie = CGI::Cookie->new( -name=>'a', 'value'=>'b' ); + $cookie->max_age( '+4d' ); + + is $cookie->expires, undef, 'expires is undef when setting max_age'; + is $cookie->max_age => 4*24*60*60, 'setting via max-age'; + + $cookie->max_age( '113' ); + is $cookie->max_age => 13, 'max_age(num) as delta'; +} + + +#---------------------------------------------------------------------------- +# bake +#---------------------------------------------------------------------------- + +BAKE: { + my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',); + eval { $cookie->bake }; + is($@,'', "calling bake() without mod_perl should survive"); +} + #----------------------------------------------------------------------------- # Apache2?::Cookie compatibility. #----------------------------------------------------------------------------- |