lib/CGI/t/cookie.t

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