1 #!/usr/local/bin/perl -w
4 use Test::More tests => 86;
5 use CGI::Util qw(escape unescape);
6 use POSIX qw(strftime);
8 #-----------------------------------------------------------------------------
9 # make sure module loaded
10 #-----------------------------------------------------------------------------
12 BEGIN {use_ok('CGI::Cookie');}
15 'foo=123; bar=qwerty; baz=wibble; qux=a1',
16 'foo=123; bar=qwerty; baz=wibble;',
17 'foo=vixen; bar=cow; baz=bitch; qux=politician',
18 'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27',
21 #-----------------------------------------------------------------------------
23 #-----------------------------------------------------------------------------
26 my $result = CGI::Cookie->parse($test_cookie[0]);
28 is(ref($result), 'HASH', "Hash ref returned in scalar context");
30 my @result = CGI::Cookie->parse($test_cookie[0]);
32 is(@result, 8, "returns correct number of fields");
34 @result = CGI::Cookie->parse($test_cookie[1]);
36 is(@result, 6, "returns correct number of fields");
38 my %result = CGI::Cookie->parse($test_cookie[0]);
40 is($result{foo}->value, '123', "cookie foo is correct");
41 is($result{bar}->value, 'qwerty', "cookie bar is correct");
42 is($result{baz}->value, 'wibble', "cookie baz is correct");
43 is($result{qux}->value, 'a1', "cookie qux is correct");
46 #-----------------------------------------------------------------------------
48 #-----------------------------------------------------------------------------
51 # make sure there are no cookies in the environment
52 delete $ENV{HTTP_COOKIE};
55 my %result = CGI::Cookie->fetch();
56 ok(keys %result == 0, "No cookies in environment, returns empty list");
58 # now set a cookie in the environment and try again
59 $ENV{HTTP_COOKIE} = $test_cookie[2];
60 %result = CGI::Cookie->fetch();
61 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
62 "expected cookies extracted");
64 is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
65 is($result{foo}->value, 'vixen', "cookie foo is correct");
66 is($result{bar}->value, 'cow', "cookie bar is correct");
67 is($result{baz}->value, 'bitch', "cookie baz is correct");
68 is($result{qux}->value, 'politician', "cookie qux is correct");
70 # Delete that and make sure it goes away
71 delete $ENV{HTTP_COOKIE};
72 %result = CGI::Cookie->fetch();
73 ok(keys %result == 0, "No cookies in environment, returns empty list");
75 # try another cookie in the other environment variable thats supposed to work
76 $ENV{COOKIE} = $test_cookie[3];
77 %result = CGI::Cookie->fetch();
78 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
79 "expected cookies extracted");
81 is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
82 is($result{foo}->value, 'a phrase', "cookie foo is correct");
83 is($result{bar}->value, 'yes, a phrase', "cookie bar is correct");
84 is($result{baz}->value, '^wibble', "cookie baz is correct");
85 is($result{qux}->value, "'", "cookie qux is correct");
88 #-----------------------------------------------------------------------------
90 #-----------------------------------------------------------------------------
93 # make sure there are no cookies in the environment
94 delete $ENV{HTTP_COOKIE};
97 my %result = CGI::Cookie->raw_fetch();
98 ok(keys %result == 0, "No cookies in environment, returns empty list");
100 # now set a cookie in the environment and try again
101 $ENV{HTTP_COOKIE} = $test_cookie[2];
102 %result = CGI::Cookie->raw_fetch();
103 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
104 "expected cookies extracted");
106 is(ref($result{foo}), '', 'Plain scalar returned');
107 is($result{foo}, 'vixen', "cookie foo is correct");
108 is($result{bar}, 'cow', "cookie bar is correct");
109 is($result{baz}, 'bitch', "cookie baz is correct");
110 is($result{qux}, 'politician', "cookie qux is correct");
112 # Delete that and make sure it goes away
113 delete $ENV{HTTP_COOKIE};
114 %result = CGI::Cookie->raw_fetch();
115 ok(keys %result == 0, "No cookies in environment, returns empty list");
117 # try another cookie in the other environment variable thats supposed to work
118 $ENV{COOKIE} = $test_cookie[3];
119 %result = CGI::Cookie->raw_fetch();
120 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
121 "expected cookies extracted");
123 is(ref($result{foo}), '', 'Plain scalar returned');
124 is($result{foo}, 'a%20phrase', "cookie foo is correct");
125 is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct");
126 is($result{baz}, '%5Ewibble', "cookie baz is correct");
127 is($result{qux}, '%27', "cookie qux is correct");
130 #-----------------------------------------------------------------------------
132 #-----------------------------------------------------------------------------
135 # Try new with full information provided
136 my $c = CGI::Cookie->new(-name => 'foo',
139 -domain => '.capricorn.com',
140 -path => '/cgi-bin/database',
143 is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
144 is($c->name , 'foo', 'name is correct');
145 is($c->value , 'bar', 'value is correct');
146 like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires in correct format');
147 is($c->domain , '.capricorn.com', 'domain is correct');
148 is($c->path , '/cgi-bin/database', 'path is correct');
149 ok($c->secure , 'secure attribute is set');
151 # now try it with the only two manditory values (should also set the default path)
152 $c = CGI::Cookie->new(-name => 'baz',
155 is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
156 is($c->name , 'baz', 'name is correct');
157 is($c->value , 'qux', 'value is correct');
158 ok(!defined $c->expires, 'expires is not set');
159 ok(!defined $c->domain , 'domain attributeis not set');
160 is($c->path, '/', 'path atribute is set to default');
161 ok(!defined $c->secure , 'secure attribute is set');
163 # I'm really not happy about the restults of this section. You pass
164 # the new method invalid arguments and it just merilly creates a
166 # I've commented them out because they currently pass but I don't
167 # think they should. I think this is testing broken behaviour :-(
169 # # This shouldn't work
170 # $c = CGI::Cookie->new(-name => 'baz' );
172 # is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
173 # is($c->name , 'baz', 'name is correct');
174 # ok(!defined $c->value, "Value is undefined ");
175 # ok(!defined $c->expires, 'expires is not set');
176 # ok(!defined $c->domain , 'domain attributeis not set');
177 # is($c->path , '/', 'path atribute is set to default');
178 # ok(!defined $c->secure , 'secure attribute is set');
182 #-----------------------------------------------------------------------------
184 #-----------------------------------------------------------------------------
187 my $c = CGI::Cookie->new(-name => 'Jam',
190 -domain => '.pie-shop.com',
196 like($c->as_string, "/$name/", "Stringified cookie contains name");
198 my $value = $c->value;
199 like($c->as_string, "/$value/", "Stringified cookie contains value");
201 my $expires = $c->expires;
202 like($c->as_string, "/$expires/", "Stringified cookie contains expires");
204 my $domain = $c->domain;
205 like($c->as_string, "/$domain/", "Stringified cookie contains domain");
208 like($c->as_string, "/$path/", "Stringified cookie contains path");
210 like($c->as_string, '/secure/', "Stringified cookie contains secure");
212 $c = CGI::Cookie->new(-name => 'Hamster-Jam',
217 like($c->as_string, "/$name/", "Stringified cookie contains name");
220 like($c->as_string, "/$value/", "Stringified cookie contains value");
222 ok($c->as_string !~ /expires/, "Stringified cookie has no expires field");
224 ok($c->as_string !~ /domain/, "Stringified cookie has no domain field");
227 like($c->as_string, "/$path/", "Stringified cookie contains path");
229 ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure");
232 #-----------------------------------------------------------------------------
234 #-----------------------------------------------------------------------------
237 my $c1 = CGI::Cookie->new(-name => 'Jam',
240 -domain => '.pie-shop.com',
245 # have to use $c1->expires because the time will occasionally be
246 # different between the two creates causing spurious failures.
247 my $c2 = CGI::Cookie->new(-name => 'Jam',
249 -expires => $c1->expires,
250 -domain => '.pie-shop.com',
255 # This looks titally whacked, but it does the -1, 0, 1 comparison
256 # thing so 0 means they match
257 is($c1->compare("$c1"), 0, "Cookies are identical");
258 is($c1->compare("$c2"), 0, "Cookies are identical");
260 $c1 = CGI::Cookie->new(-name => 'Jam',
262 -domain => '.foo.bar.com'
265 # have to use $c1->expires because the time will occasionally be
266 # different between the two creates causing spurious failures.
267 $c2 = CGI::Cookie->new(-name => 'Jam',
271 # This looks titally whacked, but it does the -1, 0, 1 comparison
272 # thing so 0 (i.e. false) means they match
273 is($c1->compare("$c1"), 0, "Cookies are identical");
274 ok($c1->compare("$c2"), "Cookies are not identical");
276 $c2->domain('.foo.bar.com');
277 is($c1->compare("$c2"), 0, "Cookies are identical");
280 #-----------------------------------------------------------------------------
281 # Test name, value, domain, secure, expires and path
282 #-----------------------------------------------------------------------------
285 my $c = CGI::Cookie->new(-name => 'Jam',
288 -domain => '.pie-shop.com',
293 is($c->name, 'Jam', 'name is correct');
294 is($c->name('Clash'), 'Clash', 'name is set correctly');
295 is($c->name, 'Clash', 'name now returns updated value');
297 # this is insane! it returns a simple scalar but can't accept one as
298 # an argument, you have to give it an arrary ref. It's totally
299 # inconsitent with these other methods :-(
300 is($c->value, 'Hamster', 'value is correct');
301 is($c->value(['Gerbil']), 'Gerbil', 'value is set correctly');
302 is($c->value, 'Gerbil', 'value now returns updated value');
304 my $exp = $c->expires;
305 like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is correct');
306 like($c->expires('+12h'), '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is set correctly');
307 like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires now returns updated value');
308 isnt($c->expires, $exp, "Expiry time has changed");
310 is($c->domain, '.pie-shop.com', 'domain is correct');
311 is($c->domain('.wibble.co.uk'), '.wibble.co.uk', 'domain is set correctly');
312 is($c->domain, '.wibble.co.uk', 'domain now returns updated value');
314 is($c->path, '/', 'path is correct');
315 is($c->path('/basket/'), '/basket/', 'path is set correctly');
316 is($c->path, '/basket/', 'path now returns updated value');
318 ok($c->secure, 'secure attribute is set');
319 ok(!$c->secure(0), 'secure attribute is cleared');
320 ok(!$c->secure, 'secure attribute is cleared');