This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH] Minor problem in cookie.t
[perl5.git] / cpan / CGI / t / cookie.t
index 539ac7a..f10d3b6 100644 (file)
@@ -1,28 +1,29 @@
-#!/usr/local/bin/perl -w
+#!perl -w
 
-use lib qw(t/lib);
 use strict;
 
-# Due to a bug in older versions of MakeMaker & Test::Harness, we must
-# ensure the blib's are in @INC, else we might use the core CGI.pm
-use lib qw(blib/lib blib/arch);
+# 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 tests => 96;
+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
@@ -30,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)");
+
+  @array   = CGI::Cookie->parse(undef);
+  $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)");
 }
 
 #-----------------------------------------------------------------------------
@@ -131,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');
 }
 
 #-----------------------------------------------------------------------------
@@ -140,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');
@@ -153,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');
@@ -165,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
@@ -191,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");
@@ -215,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");
@@ -233,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" );
 }
 
 #-----------------------------------------------------------------------------
@@ -241,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
@@ -289,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');
@@ -326,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';
+
+    $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.
 #-----------------------------------------------------------------------------