cpan/CGI/t/cookie.t

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