lib/CGI/t/cookie.t

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