lib/CGI/t/cookie.t

   1 #!/usr/local/bin/perl -w
   2
   3 BEGIN {
   4         chdir 't' if -d 't';
   5         if ($ENV{PERL_CORE}) {
   6                 @INC = '../lib';
   7         } else {
   8                 # Due to a bug in older versions of MakeMaker & Test::Harness, we must
   9                 # ensure the blib's are in @INC, else we might use the core CGI.pm
  10                 unshift @INC, qw( ../blib/lib ../blib/arch lib );
  11         }
  12 }
  13 use strict;
  14
  15 use Test::More tests => 86;
  16 use CGI::Util qw(escape unescape);
  17 use POSIX qw(strftime);
  18
  19 #-----------------------------------------------------------------------------
  20 # make sure module loaded
  21 #-----------------------------------------------------------------------------
  22
  23 BEGIN {use_ok('CGI::Cookie');}
  24
  25 my @test_cookie = (
  26                    'foo=123; bar=qwerty; baz=wibble; qux=a1',
  27                    'foo=123; bar=qwerty; baz=wibble;',
  28                    'foo=vixen; bar=cow; baz=bitch; qux=politician',
  29                    'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27',
  30                    );
  31
  32 #-----------------------------------------------------------------------------
  33 # Test parse
  34 #-----------------------------------------------------------------------------
  35
  36 {
  37   my $result = CGI::Cookie->parse($test_cookie[0]);
  38
  39   is(ref($result), 'HASH', "Hash ref returned in scalar context");
  40
  41   my @result = CGI::Cookie->parse($test_cookie[0]);
  42
  43   is(@result, 8, "returns correct number of fields");
  44
  45   @result = CGI::Cookie->parse($test_cookie[1]);
  46
  47   is(@result, 6, "returns correct number of fields");
  48
  49   my %result = CGI::Cookie->parse($test_cookie[0]);
  50
  51   is($result{foo}->value, '123', "cookie foo is correct");
  52   is($result{bar}->value, 'qwerty', "cookie bar is correct");
  53   is($result{baz}->value, 'wibble', "cookie baz is correct");
  54   is($result{qux}->value, 'a1', "cookie qux is correct");
  55 }
  56
  57 #-----------------------------------------------------------------------------
  58 # Test fetch
  59 #-----------------------------------------------------------------------------
  60
  61 {
  62   # make sure there are no cookies in the environment
  63   delete $ENV{HTTP_COOKIE};
  64   delete $ENV{COOKIE};
  65
  66   my %result = CGI::Cookie->fetch();
  67   ok(keys %result == 0, "No cookies in environment, returns empty list");
  68
  69   # now set a cookie in the environment and try again
  70   $ENV{HTTP_COOKIE} = $test_cookie[2];
  71   %result = CGI::Cookie->fetch();
  72   ok(eq_set([keys %result], [qw(foo bar baz qux)]),
  73      "expected cookies extracted");
  74
  75   is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
  76   is($result{foo}->value, 'vixen',      "cookie foo is correct");
  77   is($result{bar}->value, 'cow',        "cookie bar is correct");
  78   is($result{baz}->value, 'bitch',      "cookie baz is correct");
  79   is($result{qux}->value, 'politician', "cookie qux is correct");
  80
  81   # Delete that and make sure it goes away
  82   delete $ENV{HTTP_COOKIE};
  83   %result = CGI::Cookie->fetch();
  84   ok(keys %result == 0, "No cookies in environment, returns empty list");
  85
  86   # try another cookie in the other environment variable thats supposed to work
  87   $ENV{COOKIE} = $test_cookie[3];
  88   %result = CGI::Cookie->fetch();
  89   ok(eq_set([keys %result], [qw(foo bar baz qux)]),
  90      "expected cookies extracted");
  91
  92   is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
  93   is($result{foo}->value, 'a phrase', "cookie foo is correct");
  94   is($result{bar}->value, 'yes, a phrase', "cookie bar is correct");
  95   is($result{baz}->value, '^wibble', "cookie baz is correct");
  96   is($result{qux}->value, "'", "cookie qux is correct");
  97 }
  98
  99 #-----------------------------------------------------------------------------
 100 # Test raw_fetch
 101 #-----------------------------------------------------------------------------
 102
 103 {
 104   # make sure there are no cookies in the environment
 105   delete $ENV{HTTP_COOKIE};
 106   delete $ENV{COOKIE};
 107
 108   my %result = CGI::Cookie->raw_fetch();
 109   ok(keys %result == 0, "No cookies in environment, returns empty list");
 110
 111   # now set a cookie in the environment and try again
 112   $ENV{HTTP_COOKIE} = $test_cookie[2];
 113   %result = CGI::Cookie->raw_fetch();
 114   ok(eq_set([keys %result], [qw(foo bar baz qux)]),
 115      "expected cookies extracted");
 116
 117   is(ref($result{foo}), '', 'Plain scalar returned');
 118   is($result{foo}, 'vixen',      "cookie foo is correct");
 119   is($result{bar}, 'cow',        "cookie bar is correct");
 120   is($result{baz}, 'bitch',      "cookie baz is correct");
 121   is($result{qux}, 'politician', "cookie qux is correct");
 122
 123   # Delete that and make sure it goes away
 124   delete $ENV{HTTP_COOKIE};
 125   %result = CGI::Cookie->raw_fetch();
 126   ok(keys %result == 0, "No cookies in environment, returns empty list");
 127
 128   # try another cookie in the other environment variable thats supposed to work
 129   $ENV{COOKIE} = $test_cookie[3];
 130   %result = CGI::Cookie->raw_fetch();
 131   ok(eq_set([keys %result], [qw(foo bar baz qux)]),
 132      "expected cookies extracted");
 133
 134   is(ref($result{foo}), '', 'Plain scalar returned');
 135   is($result{foo}, 'a%20phrase', "cookie foo is correct");
 136   is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct");
 137   is($result{baz}, '%5Ewibble', "cookie baz is correct");
 138   is($result{qux}, '%27', "cookie qux is correct");
 139 }
 140
 141 #-----------------------------------------------------------------------------
 142 # Test new
 143 #-----------------------------------------------------------------------------
 144
 145 {
 146   # Try new with full information provided
 147   my $c = CGI::Cookie->new(-name    => 'foo',
 148                            -value   => 'bar',
 149                            -expires => '+3M',
 150                            -domain  => '.capricorn.com',
 151                            -path    => '/cgi-bin/database',
 152                            -secure  => 1
 153                           );
 154   is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
 155   is($c->name   , 'foo',               'name is correct');
 156   is($c->value  , 'bar',               'value is correct');
 157   like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires in correct format');
 158   is($c->domain , '.capricorn.com',    'domain is correct');
 159   is($c->path   , '/cgi-bin/database', 'path is correct');
 160   ok($c->secure , 'secure attribute is set');
 161
 162   # now try it with the only two manditory values (should also set the default path)
 163   $c = CGI::Cookie->new(-name    =>  'baz',
 164                         -value   =>  'qux',
 165                        );
 166   is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
 167   is($c->name   , 'baz', 'name is correct');
 168   is($c->value  , 'qux', 'value is correct');
 169   ok(!defined $c->expires,       'expires is not set');
 170   ok(!defined $c->domain ,       'domain attributeis not set');
 171   is($c->path, '/',      'path atribute is set to default');
 172   ok(!defined $c->secure ,       'secure attribute is set');
 173
 174 # I'm really not happy about the restults of this section.  You pass
 175 # the new method invalid arguments and it just merilly creates a
 176 # broken object :-)
 177 # I've commented them out because they currently pass but I don't
 178 # think they should.  I think this is testing broken behaviour :-(
 179
 180 #    # This shouldn't work
 181 #    $c = CGI::Cookie->new(-name => 'baz' );
 182 #
 183 #    is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
 184 #    is($c->name   , 'baz',     'name is correct');
 185 #    ok(!defined $c->value, "Value is undefined ");
 186 #    ok(!defined $c->expires, 'expires is not set');
 187 #    ok(!defined $c->domain , 'domain attributeis not set');
 188 #    is($c->path   , '/', 'path atribute is set to default');
 189 #    ok(!defined $c->secure , 'secure attribute is set');
 190
 191 }
 192
 193 #-----------------------------------------------------------------------------
 194 # Test as_string
 195 #-----------------------------------------------------------------------------
 196
 197 {
 198   my $c = CGI::Cookie->new(-name    => 'Jam',
 199                            -value   => 'Hamster',
 200                            -expires => '+3M',
 201                            -domain  => '.pie-shop.com',
 202                            -path    => '/',
 203                            -secure  => 1
 204                           );
 205
 206   my $name = $c->name;
 207   like($c->as_string, "/$name/", "Stringified cookie contains name");
 208
 209   my $value = $c->value;
 210   like($c->as_string, "/$value/", "Stringified cookie contains value");
 211
 212   my $expires = $c->expires;
 213   like($c->as_string, "/$expires/", "Stringified cookie contains expires");
 214
 215   my $domain = $c->domain;
 216   like($c->as_string, "/$domain/", "Stringified cookie contains domain");
 217
 218   my $path = $c->path;
 219   like($c->as_string, "/$path/", "Stringified cookie contains path");
 220
 221   like($c->as_string, '/secure/', "Stringified cookie contains secure");
 222
 223   $c = CGI::Cookie->new(-name    =>  'Hamster-Jam',
 224                         -value   =>  'Tulip',
 225                        );
 226
 227   $name = $c->name;
 228   like($c->as_string, "/$name/", "Stringified cookie contains name");
 229
 230   $value = $c->value;
 231   like($c->as_string, "/$value/", "Stringified cookie contains value");
 232
 233   ok($c->as_string !~ /expires/, "Stringified cookie has no expires field");
 234
 235   ok($c->as_string !~ /domain/, "Stringified cookie has no domain field");
 236
 237   $path = $c->path;
 238   like($c->as_string, "/$path/", "Stringified cookie contains path");
 239
 240   ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure");
 241 }
 242
 243 #-----------------------------------------------------------------------------
 244 # Test compare
 245 #-----------------------------------------------------------------------------
 246
 247 {
 248   my $c1 = CGI::Cookie->new(-name    => 'Jam',
 249                             -value   => 'Hamster',
 250                             -expires => '+3M',
 251                             -domain  => '.pie-shop.com',
 252                             -path    => '/',
 253                             -secure  => 1
 254                            );
 255
 256   # have to use $c1->expires because the time will occasionally be
 257   # different between the two creates causing spurious failures.
 258   my $c2 = CGI::Cookie->new(-name    => 'Jam',
 259                             -value   => 'Hamster',
 260                             -expires => $c1->expires,
 261                             -domain  => '.pie-shop.com',
 262                             -path    => '/',
 263                             -secure  => 1
 264                            );
 265
 266   # This looks titally whacked, but it does the -1, 0, 1 comparison
 267   # thing so 0 means they match
 268   is($c1->compare("$c1"), 0, "Cookies are identical");
 269   is($c1->compare("$c2"), 0, "Cookies are identical");
 270
 271   $c1 = CGI::Cookie->new(-name   => 'Jam',
 272                          -value  => 'Hamster',
 273                          -domain => '.foo.bar.com'
 274                         );
 275
 276   # have to use $c1->expires because the time will occasionally be
 277   # different between the two creates causing spurious failures.
 278   $c2 = CGI::Cookie->new(-name    =>  'Jam',
 279                          -value   =>  'Hamster',
 280                         );
 281
 282   # This looks titally whacked, but it does the -1, 0, 1 comparison
 283   # thing so 0 (i.e. false) means they match
 284   is($c1->compare("$c1"), 0, "Cookies are identical");
 285   ok($c1->compare("$c2"), "Cookies are not identical");
 286
 287   $c2->domain('.foo.bar.com');
 288   is($c1->compare("$c2"), 0, "Cookies are identical");
 289 }
 290
 291 #-----------------------------------------------------------------------------
 292 # Test name, value, domain, secure, expires and path
 293 #-----------------------------------------------------------------------------
 294
 295 {
 296   my $c = CGI::Cookie->new(-name    => 'Jam',
 297                            -value   => 'Hamster',
 298                            -expires => '+3M',
 299                            -domain  => '.pie-shop.com',
 300                            -path    => '/',
 301                            -secure  => 1
 302                            );
 303
 304   is($c->name,          'Jam',   'name is correct');
 305   is($c->name('Clash'), 'Clash', 'name is set correctly');
 306   is($c->name,          'Clash', 'name now returns updated value');
 307
 308   # this is insane!  it returns a simple scalar but can't accept one as
 309   # an argument, you have to give it an arrary ref.  It's totally
 310   # inconsitent with these other methods :-(
 311   is($c->value,           'Hamster', 'value is correct');
 312   is($c->value(['Gerbil']), 'Gerbil',  'value is set correctly');
 313   is($c->value,           'Gerbil',  'value now returns updated value');
 314
 315   my $exp = $c->expires;
 316   like($c->expires,         '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is correct');
 317   like($c->expires('+12h'), '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is set correctly');
 318   like($c->expires,         '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires now returns updated value');
 319   isnt($c->expires, $exp, "Expiry time has changed");
 320
 321   is($c->domain,                  '.pie-shop.com', 'domain is correct');
 322   is($c->domain('.wibble.co.uk'), '.wibble.co.uk', 'domain is set correctly');
 323   is($c->domain,                  '.wibble.co.uk', 'domain now returns updated value');
 324
 325   is($c->path,             '/',        'path is correct');
 326   is($c->path('/basket/'), '/basket/', 'path is set correctly');
 327   is($c->path,             '/basket/', 'path now returns updated value');
 328
 329   ok($c->secure,     'secure attribute is set');
 330   ok(!$c->secure(0), 'secure attribute is cleared');
 331   ok(!$c->secure,    'secure attribute is cleared');
 332 }