Home | History | Annotate | Download | only in 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} = \@_; }
    376