Integrate with perlio; (strictly) readonly hashes via XS.
[p5sagit/p5-mst-13.2.git] / lib / CGI / t / cookie.t
CommitLineData
2447c5f5 1#!/usr/local/bin/perl -w
2
88587957 3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6}
7
2447c5f5 8use strict;
9use Test::More tests => 86;
10use CGI::Util qw(escape unescape);
11use POSIX qw(strftime);
12
13#-----------------------------------------------------------------------------
14# make sure module loaded
15#-----------------------------------------------------------------------------
16
17BEGIN {use_ok('CGI::Cookie');}
18
19my @test_cookie = (
20 'foo=123; bar=qwerty; baz=wibble; qux=a1',
21 'foo=123; bar=qwerty; baz=wibble;',
22 'foo=vixen; bar=cow; baz=bitch; qux=politician',
23 'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27',
24 );
25
26#-----------------------------------------------------------------------------
27# Test parse
28#-----------------------------------------------------------------------------
29
30{
31 my $result = CGI::Cookie->parse($test_cookie[0]);
32
33 is(ref($result), 'HASH', "Hash ref returned in scalar context");
34
35 my @result = CGI::Cookie->parse($test_cookie[0]);
36
37 is(@result, 8, "returns correct number of fields");
38
39 @result = CGI::Cookie->parse($test_cookie[1]);
40
41 is(@result, 6, "returns correct number of fields");
42
43 my %result = CGI::Cookie->parse($test_cookie[0]);
44
45 is($result{foo}->value, '123', "cookie foo is correct");
46 is($result{bar}->value, 'qwerty', "cookie bar is correct");
47 is($result{baz}->value, 'wibble', "cookie baz is correct");
48 is($result{qux}->value, 'a1', "cookie qux is correct");
49}
50
51#-----------------------------------------------------------------------------
52# Test fetch
53#-----------------------------------------------------------------------------
54
55{
56 # make sure there are no cookies in the environment
57 delete $ENV{HTTP_COOKIE};
58 delete $ENV{COOKIE};
59
60 my %result = CGI::Cookie->fetch();
61 ok(keys %result == 0, "No cookies in environment, returns empty list");
62
63 # now set a cookie in the environment and try again
64 $ENV{HTTP_COOKIE} = $test_cookie[2];
65 %result = CGI::Cookie->fetch();
66 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
67 "expected cookies extracted");
68
69 is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
70 is($result{foo}->value, 'vixen', "cookie foo is correct");
71 is($result{bar}->value, 'cow', "cookie bar is correct");
72 is($result{baz}->value, 'bitch', "cookie baz is correct");
73 is($result{qux}->value, 'politician', "cookie qux is correct");
74
75 # Delete that and make sure it goes away
76 delete $ENV{HTTP_COOKIE};
77 %result = CGI::Cookie->fetch();
78 ok(keys %result == 0, "No cookies in environment, returns empty list");
79
80 # try another cookie in the other environment variable thats supposed to work
81 $ENV{COOKIE} = $test_cookie[3];
82 %result = CGI::Cookie->fetch();
83 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
84 "expected cookies extracted");
85
86 is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
87 is($result{foo}->value, 'a phrase', "cookie foo is correct");
88 is($result{bar}->value, 'yes, a phrase', "cookie bar is correct");
89 is($result{baz}->value, '^wibble', "cookie baz is correct");
90 is($result{qux}->value, "'", "cookie qux is correct");
91}
92
93#-----------------------------------------------------------------------------
94# Test raw_fetch
95#-----------------------------------------------------------------------------
96
97{
98 # make sure there are no cookies in the environment
99 delete $ENV{HTTP_COOKIE};
100 delete $ENV{COOKIE};
101
102 my %result = CGI::Cookie->raw_fetch();
103 ok(keys %result == 0, "No cookies in environment, returns empty list");
104
105 # now set a cookie in the environment and try again
106 $ENV{HTTP_COOKIE} = $test_cookie[2];
107 %result = CGI::Cookie->raw_fetch();
108 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
109 "expected cookies extracted");
110
111 is(ref($result{foo}), '', 'Plain scalar returned');
112 is($result{foo}, 'vixen', "cookie foo is correct");
113 is($result{bar}, 'cow', "cookie bar is correct");
114 is($result{baz}, 'bitch', "cookie baz is correct");
115 is($result{qux}, 'politician', "cookie qux is correct");
116
117 # Delete that and make sure it goes away
118 delete $ENV{HTTP_COOKIE};
119 %result = CGI::Cookie->raw_fetch();
120 ok(keys %result == 0, "No cookies in environment, returns empty list");
121
122 # try another cookie in the other environment variable thats supposed to work
123 $ENV{COOKIE} = $test_cookie[3];
124 %result = CGI::Cookie->raw_fetch();
125 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
126 "expected cookies extracted");
127
128 is(ref($result{foo}), '', 'Plain scalar returned');
129 is($result{foo}, 'a%20phrase', "cookie foo is correct");
130 is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct");
131 is($result{baz}, '%5Ewibble', "cookie baz is correct");
132 is($result{qux}, '%27', "cookie qux is correct");
133}
134
135#-----------------------------------------------------------------------------
136# Test new
137#-----------------------------------------------------------------------------
138
139{
140 # Try new with full information provided
141 my $c = CGI::Cookie->new(-name => 'foo',
142 -value => 'bar',
143 -expires => '+3M',
144 -domain => '.capricorn.com',
145 -path => '/cgi-bin/database',
146 -secure => 1
147 );
148 is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
149 is($c->name , 'foo', 'name is correct');
150 is($c->value , 'bar', 'value is correct');
151 like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires in correct format');
152 is($c->domain , '.capricorn.com', 'domain is correct');
153 is($c->path , '/cgi-bin/database', 'path is correct');
154 ok($c->secure , 'secure attribute is set');
155
156 # now try it with the only two manditory values (should also set the default path)
157 $c = CGI::Cookie->new(-name => 'baz',
158 -value => 'qux',
159 );
160 is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
161 is($c->name , 'baz', 'name is correct');
162 is($c->value , 'qux', 'value is correct');
163 ok(!defined $c->expires, 'expires is not set');
164 ok(!defined $c->domain , 'domain attributeis not set');
165 is($c->path, '/', 'path atribute is set to default');
166 ok(!defined $c->secure , 'secure attribute is set');
167
168# I'm really not happy about the restults of this section. You pass
169# the new method invalid arguments and it just merilly creates a
170# broken object :-)
171# I've commented them out because they currently pass but I don't
172# think they should. I think this is testing broken behaviour :-(
173
174# # This shouldn't work
175# $c = CGI::Cookie->new(-name => 'baz' );
176#
177# is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
178# is($c->name , 'baz', 'name is correct');
179# ok(!defined $c->value, "Value is undefined ");
180# ok(!defined $c->expires, 'expires is not set');
181# ok(!defined $c->domain , 'domain attributeis not set');
182# is($c->path , '/', 'path atribute is set to default');
183# ok(!defined $c->secure , 'secure attribute is set');
184
185}
186
187#-----------------------------------------------------------------------------
188# Test as_string
189#-----------------------------------------------------------------------------
190
191{
192 my $c = CGI::Cookie->new(-name => 'Jam',
193 -value => 'Hamster',
194 -expires => '+3M',
195 -domain => '.pie-shop.com',
196 -path => '/',
197 -secure => 1
198 );
199
200 my $name = $c->name;
201 like($c->as_string, "/$name/", "Stringified cookie contains name");
202
203 my $value = $c->value;
204 like($c->as_string, "/$value/", "Stringified cookie contains value");
205
206 my $expires = $c->expires;
207 like($c->as_string, "/$expires/", "Stringified cookie contains expires");
208
209 my $domain = $c->domain;
210 like($c->as_string, "/$domain/", "Stringified cookie contains domain");
211
212 my $path = $c->path;
213 like($c->as_string, "/$path/", "Stringified cookie contains path");
214
215 like($c->as_string, '/secure/', "Stringified cookie contains secure");
216
217 $c = CGI::Cookie->new(-name => 'Hamster-Jam',
218 -value => 'Tulip',
219 );
220
221 $name = $c->name;
222 like($c->as_string, "/$name/", "Stringified cookie contains name");
223
224 $value = $c->value;
225 like($c->as_string, "/$value/", "Stringified cookie contains value");
226
227 ok($c->as_string !~ /expires/, "Stringified cookie has no expires field");
228
229 ok($c->as_string !~ /domain/, "Stringified cookie has no domain field");
230
231 $path = $c->path;
232 like($c->as_string, "/$path/", "Stringified cookie contains path");
233
234 ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure");
235}
236
237#-----------------------------------------------------------------------------
238# Test compare
239#-----------------------------------------------------------------------------
240
241{
242 my $c1 = CGI::Cookie->new(-name => 'Jam',
243 -value => 'Hamster',
244 -expires => '+3M',
245 -domain => '.pie-shop.com',
246 -path => '/',
247 -secure => 1
248 );
249
250 # have to use $c1->expires because the time will occasionally be
251 # different between the two creates causing spurious failures.
252 my $c2 = CGI::Cookie->new(-name => 'Jam',
253 -value => 'Hamster',
254 -expires => $c1->expires,
255 -domain => '.pie-shop.com',
256 -path => '/',
257 -secure => 1
258 );
259
260 # This looks titally whacked, but it does the -1, 0, 1 comparison
261 # thing so 0 means they match
262 is($c1->compare("$c1"), 0, "Cookies are identical");
263 is($c1->compare("$c2"), 0, "Cookies are identical");
264
265 $c1 = CGI::Cookie->new(-name => 'Jam',
266 -value => 'Hamster',
267 -domain => '.foo.bar.com'
268 );
269
270 # have to use $c1->expires because the time will occasionally be
271 # different between the two creates causing spurious failures.
272 $c2 = CGI::Cookie->new(-name => 'Jam',
273 -value => 'Hamster',
274 );
275
276 # This looks titally whacked, but it does the -1, 0, 1 comparison
277 # thing so 0 (i.e. false) means they match
278 is($c1->compare("$c1"), 0, "Cookies are identical");
279 ok($c1->compare("$c2"), "Cookies are not identical");
280
281 $c2->domain('.foo.bar.com');
282 is($c1->compare("$c2"), 0, "Cookies are identical");
283}
284
285#-----------------------------------------------------------------------------
286# Test name, value, domain, secure, expires and path
287#-----------------------------------------------------------------------------
288
289{
290 my $c = CGI::Cookie->new(-name => 'Jam',
291 -value => 'Hamster',
292 -expires => '+3M',
293 -domain => '.pie-shop.com',
294 -path => '/',
295 -secure => 1
296 );
297
298 is($c->name, 'Jam', 'name is correct');
299 is($c->name('Clash'), 'Clash', 'name is set correctly');
300 is($c->name, 'Clash', 'name now returns updated value');
301
302 # this is insane! it returns a simple scalar but can't accept one as
303 # an argument, you have to give it an arrary ref. It's totally
304 # inconsitent with these other methods :-(
305 is($c->value, 'Hamster', 'value is correct');
306 is($c->value(['Gerbil']), 'Gerbil', 'value is set correctly');
307 is($c->value, 'Gerbil', 'value now returns updated value');
308
309 my $exp = $c->expires;
310 like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is correct');
311 like($c->expires('+12h'), '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is set correctly');
312 like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires now returns updated value');
313 isnt($c->expires, $exp, "Expiry time has changed");
314
315 is($c->domain, '.pie-shop.com', 'domain is correct');
316 is($c->domain('.wibble.co.uk'), '.wibble.co.uk', 'domain is set correctly');
317 is($c->domain, '.wibble.co.uk', 'domain now returns updated value');
318
319 is($c->path, '/', 'path is correct');
320 is($c->path('/basket/'), '/basket/', 'path is set correctly');
321 is($c->path, '/basket/', 'path now returns updated value');
322
323 ok($c->secure, 'secure attribute is set');
324 ok(!$c->secure(0), 'secure attribute is cleared');
325 ok(!$c->secure, 'secure attribute is cleared');
326}