This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
CGI::Cookie, Apache & Switch tests
[perl5.git] / lib / CGI / t / cookie.t
CommitLineData
2447c5f5
MS
1#!/usr/local/bin/perl -w
2
3use strict;
4use Test::More tests => 86;
5use CGI::Util qw(escape unescape);
6use POSIX qw(strftime);
7
8#-----------------------------------------------------------------------------
9# make sure module loaded
10#-----------------------------------------------------------------------------
11
12BEGIN {use_ok('CGI::Cookie');}
13
14my @test_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',
19 );
20
21#-----------------------------------------------------------------------------
22# Test parse
23#-----------------------------------------------------------------------------
24
25{
26 my $result = CGI::Cookie->parse($test_cookie[0]);
27
28 is(ref($result), 'HASH', "Hash ref returned in scalar context");
29
30 my @result = CGI::Cookie->parse($test_cookie[0]);
31
32 is(@result, 8, "returns correct number of fields");
33
34 @result = CGI::Cookie->parse($test_cookie[1]);
35
36 is(@result, 6, "returns correct number of fields");
37
38 my %result = CGI::Cookie->parse($test_cookie[0]);
39
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");
44}
45
46#-----------------------------------------------------------------------------
47# Test fetch
48#-----------------------------------------------------------------------------
49
50{
51 # make sure there are no cookies in the environment
52 delete $ENV{HTTP_COOKIE};
53 delete $ENV{COOKIE};
54
55 my %result = CGI::Cookie->fetch();
56 ok(keys %result == 0, "No cookies in environment, returns empty list");
57
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");
63
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");
69
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");
74
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");
80
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");
86}
87
88#-----------------------------------------------------------------------------
89# Test raw_fetch
90#-----------------------------------------------------------------------------
91
92{
93 # make sure there are no cookies in the environment
94 delete $ENV{HTTP_COOKIE};
95 delete $ENV{COOKIE};
96
97 my %result = CGI::Cookie->raw_fetch();
98 ok(keys %result == 0, "No cookies in environment, returns empty list");
99
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");
105
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");
111
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");
116
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");
122
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");
128}
129
130#-----------------------------------------------------------------------------
131# Test new
132#-----------------------------------------------------------------------------
133
134{
135 # Try new with full information provided
136 my $c = CGI::Cookie->new(-name => 'foo',
137 -value => 'bar',
138 -expires => '+3M',
139 -domain => '.capricorn.com',
140 -path => '/cgi-bin/database',
141 -secure => 1
142 );
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');
150
151 # now try it with the only two manditory values (should also set the default path)
152 $c = CGI::Cookie->new(-name => 'baz',
153 -value => 'qux',
154 );
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');
162
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
165# broken object :-)
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 :-(
168
169# # This shouldn't work
170# $c = CGI::Cookie->new(-name => 'baz' );
171#
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');
179
180}
181
182#-----------------------------------------------------------------------------
183# Test as_string
184#-----------------------------------------------------------------------------
185
186{
187 my $c = CGI::Cookie->new(-name => 'Jam',
188 -value => 'Hamster',
189 -expires => '+3M',
190 -domain => '.pie-shop.com',
191 -path => '/',
192 -secure => 1
193 );
194
195 my $name = $c->name;
196 like($c->as_string, "/$name/", "Stringified cookie contains name");
197
198 my $value = $c->value;
199 like($c->as_string, "/$value/", "Stringified cookie contains value");
200
201 my $expires = $c->expires;
202 like($c->as_string, "/$expires/", "Stringified cookie contains expires");
203
204 my $domain = $c->domain;
205 like($c->as_string, "/$domain/", "Stringified cookie contains domain");
206
207 my $path = $c->path;
208 like($c->as_string, "/$path/", "Stringified cookie contains path");
209
210 like($c->as_string, '/secure/', "Stringified cookie contains secure");
211
212 $c = CGI::Cookie->new(-name => 'Hamster-Jam',
213 -value => 'Tulip',
214 );
215
216 $name = $c->name;
217 like($c->as_string, "/$name/", "Stringified cookie contains name");
218
219 $value = $c->value;
220 like($c->as_string, "/$value/", "Stringified cookie contains value");
221
222 ok($c->as_string !~ /expires/, "Stringified cookie has no expires field");
223
224 ok($c->as_string !~ /domain/, "Stringified cookie has no domain field");
225
226 $path = $c->path;
227 like($c->as_string, "/$path/", "Stringified cookie contains path");
228
229 ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure");
230}
231
232#-----------------------------------------------------------------------------
233# Test compare
234#-----------------------------------------------------------------------------
235
236{
237 my $c1 = CGI::Cookie->new(-name => 'Jam',
238 -value => 'Hamster',
239 -expires => '+3M',
240 -domain => '.pie-shop.com',
241 -path => '/',
242 -secure => 1
243 );
244
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',
248 -value => 'Hamster',
249 -expires => $c1->expires,
250 -domain => '.pie-shop.com',
251 -path => '/',
252 -secure => 1
253 );
254
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");
259
260 $c1 = CGI::Cookie->new(-name => 'Jam',
261 -value => 'Hamster',
262 -domain => '.foo.bar.com'
263 );
264
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',
268 -value => 'Hamster',
269 );
270
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");
275
276 $c2->domain('.foo.bar.com');
277 is($c1->compare("$c2"), 0, "Cookies are identical");
278}
279
280#-----------------------------------------------------------------------------
281# Test name, value, domain, secure, expires and path
282#-----------------------------------------------------------------------------
283
284{
285 my $c = CGI::Cookie->new(-name => 'Jam',
286 -value => 'Hamster',
287 -expires => '+3M',
288 -domain => '.pie-shop.com',
289 -path => '/',
290 -secure => 1
291 );
292
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');
296
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');
303
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");
309
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');
313
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');
317
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');
321}