cpan/CGI/t/cookie.t

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