1#!/usr/local/bin/perl -w 2 3use lib qw(t/lib); 4use 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 8use lib qw(blib/lib blib/arch); 9 10use Test::More tests => 96; 11use CGI::Util qw(escape unescape); 12use POSIX qw(strftime); 13 14#----------------------------------------------------------------------------- 15# make sure module loaded 16#----------------------------------------------------------------------------- 17 18BEGIN {use_ok('CGI::Cookie');} 19 20my @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#----------------------------------------------------------------------------- 332APACHEREQ: { 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 359package Apache::Faker; 360sub new { bless {}, shift } 361sub isa { 362 my ($self, $pkg) = @_; 363 return $pkg eq 'Apache'; 364} 365sub headers_out { shift } 366sub add { shift->{check} = \@_; } 367 368package Apache2::Faker; 369sub new { bless {}, shift } 370sub isa { 371 my ($self, $pkg) = @_; 372 return $pkg eq 'Apache2::RequestReq'; 373} 374sub headers_out { shift } 375sub add { shift->{check} = \@_; } 376