| Commit | Line | Data |
|---|
| 2447c5f5 |
1 | #!/usr/local/bin/perl -w |
| 2 | |
| 8f3ccfa2 |
3 | use lib qw(t/lib); |
| 2447c5f5 |
4 | use strict; |
| ac734d8b |
5 | |
| 8f3ccfa2 |
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 | |
| 2447c5f5 |
10 | use Test::More tests => 86; |
| 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 | } |
projects / p5sagit/p5-mst-13.2.git / blame