This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH] Minor problem in cookie.t
[perl5.git] / cpan / CGI / t / cookie.t
CommitLineData
2a1594f6 1#!perl -w
2447c5f5
MS
2
3use strict;
ac734d8b 4
2a1594f6
CBW
5# to have a consistent baseline, we nail the current time
6# to 100 seconds after the epoch
7BEGIN {
8 *CORE::GLOBAL::time = sub { 100 };
9}
10
11use Test::More 'no_plan';
2447c5f5
MS
12use CGI::Util qw(escape unescape);
13use POSIX qw(strftime);
2a1594f6 14use CGI::Cookie;
2447c5f5
MS
15
16#-----------------------------------------------------------------------------
17# make sure module loaded
18#-----------------------------------------------------------------------------
19
2447c5f5 20my @test_cookie = (
2a1594f6
CBW
21 # including leading and trailing whitespace in first cookie
22 ' foo=123 ; bar=qwerty; baz=wibble; qux=a1',
23 'foo=123; bar=qwerty; baz=wibble;',
24 'foo=vixen; bar=cow; baz=bitch; qux=politician',
25 'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27',
26 );
2447c5f5
MS
27
28#-----------------------------------------------------------------------------
29# Test parse
30#-----------------------------------------------------------------------------
31
32{
33 my $result = CGI::Cookie->parse($test_cookie[0]);
2447c5f5
MS
34 is(ref($result), 'HASH', "Hash ref returned in scalar context");
35
36 my @result = CGI::Cookie->parse($test_cookie[0]);
2447c5f5
MS
37 is(@result, 8, "returns correct number of fields");
38
39 @result = CGI::Cookie->parse($test_cookie[1]);
2447c5f5
MS
40 is(@result, 6, "returns correct number of fields");
41
42 my %result = CGI::Cookie->parse($test_cookie[0]);
2447c5f5
MS
43 is($result{foo}->value, '123', "cookie foo is correct");
44 is($result{bar}->value, 'qwerty', "cookie bar is correct");
45 is($result{baz}->value, 'wibble', "cookie baz is correct");
46 is($result{qux}->value, 'a1', "cookie qux is correct");
2a1594f6
CBW
47
48 my @array = CGI::Cookie->parse('');
49 my $scalar = CGI::Cookie->parse('');
50 is_deeply(\@array, [], " parse('') returns an empty array in list context (undocumented)");
51 is_deeply($scalar, {}, " parse('') returns an empty hashref in scalar context (undocumented)");
52
698bc959
RT
53 @array = CGI::Cookie->parse(undef);
54 $scalar = CGI::Cookie->parse(undef);
2a1594f6
CBW
55 is_deeply(\@array, [], " parse(undef) returns an empty array in list context (undocumented)");
56 is_deeply($scalar, {}, " parse(undef) returns an empty hashref in scalar context (undocumented)");
2447c5f5
MS
57}
58
59#-----------------------------------------------------------------------------
60# Test fetch
61#-----------------------------------------------------------------------------
62
63{
64 # make sure there are no cookies in the environment
65 delete $ENV{HTTP_COOKIE};
66 delete $ENV{COOKIE};
67
68 my %result = CGI::Cookie->fetch();
69 ok(keys %result == 0, "No cookies in environment, returns empty list");
70
71 # now set a cookie in the environment and try again
72 $ENV{HTTP_COOKIE} = $test_cookie[2];
73 %result = CGI::Cookie->fetch();
74 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
75 "expected cookies extracted");
76
77 is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
78 is($result{foo}->value, 'vixen', "cookie foo is correct");
79 is($result{bar}->value, 'cow', "cookie bar is correct");
80 is($result{baz}->value, 'bitch', "cookie baz is correct");
81 is($result{qux}->value, 'politician', "cookie qux is correct");
82
83 # Delete that and make sure it goes away
84 delete $ENV{HTTP_COOKIE};
85 %result = CGI::Cookie->fetch();
86 ok(keys %result == 0, "No cookies in environment, returns empty list");
87
88 # try another cookie in the other environment variable thats supposed to work
89 $ENV{COOKIE} = $test_cookie[3];
90 %result = CGI::Cookie->fetch();
91 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
92 "expected cookies extracted");
93
94 is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
95 is($result{foo}->value, 'a phrase', "cookie foo is correct");
96 is($result{bar}->value, 'yes, a phrase', "cookie bar is correct");
97 is($result{baz}->value, '^wibble', "cookie baz is correct");
98 is($result{qux}->value, "'", "cookie qux is correct");
99}
100
101#-----------------------------------------------------------------------------
102# Test raw_fetch
103#-----------------------------------------------------------------------------
104
105{
106 # make sure there are no cookies in the environment
107 delete $ENV{HTTP_COOKIE};
108 delete $ENV{COOKIE};
109
110 my %result = CGI::Cookie->raw_fetch();
111 ok(keys %result == 0, "No cookies in environment, returns empty list");
112
113 # now set a cookie in the environment and try again
114 $ENV{HTTP_COOKIE} = $test_cookie[2];
115 %result = CGI::Cookie->raw_fetch();
116 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
117 "expected cookies extracted");
118
119 is(ref($result{foo}), '', 'Plain scalar returned');
120 is($result{foo}, 'vixen', "cookie foo is correct");
121 is($result{bar}, 'cow', "cookie bar is correct");
122 is($result{baz}, 'bitch', "cookie baz is correct");
123 is($result{qux}, 'politician', "cookie qux is correct");
124
125 # Delete that and make sure it goes away
126 delete $ENV{HTTP_COOKIE};
127 %result = CGI::Cookie->raw_fetch();
128 ok(keys %result == 0, "No cookies in environment, returns empty list");
129
130 # try another cookie in the other environment variable thats supposed to work
131 $ENV{COOKIE} = $test_cookie[3];
132 %result = CGI::Cookie->raw_fetch();
133 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
134 "expected cookies extracted");
135
136 is(ref($result{foo}), '', 'Plain scalar returned');
137 is($result{foo}, 'a%20phrase', "cookie foo is correct");
138 is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct");
139 is($result{baz}, '%5Ewibble', "cookie baz is correct");
140 is($result{qux}, '%27', "cookie qux is correct");
2a1594f6
CBW
141
142 $ENV{COOKIE} = '$Version=1; foo; $Path="/test"';
143 %result = CGI::Cookie->raw_fetch();
144 is($result{foo}, '', 'no value translates to empty string');
2447c5f5
MS
145}
146
147#-----------------------------------------------------------------------------
148# Test new
149#-----------------------------------------------------------------------------
150
151{
152 # Try new with full information provided
153 my $c = CGI::Cookie->new(-name => 'foo',
2a1594f6
CBW
154 -value => 'bar',
155 -expires => '+3M',
156 -domain => '.capricorn.com',
157 -path => '/cgi-bin/database',
158 -secure => 1,
159 -httponly=> 1
160 );
2447c5f5
MS
161 is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
162 is($c->name , 'foo', 'name is correct');
163 is($c->value , 'bar', 'value is correct');
164 like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires in correct format');
165 is($c->domain , '.capricorn.com', 'domain is correct');
166 is($c->path , '/cgi-bin/database', 'path is correct');
167 ok($c->secure , 'secure attribute is set');
2a1594f6 168 ok( $c->httponly, 'httponly attribute is set' );
2447c5f5
MS
169
170 # now try it with the only two manditory values (should also set the default path)
171 $c = CGI::Cookie->new(-name => 'baz',
2a1594f6
CBW
172 -value => 'qux',
173 );
2447c5f5
MS
174 is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
175 is($c->name , 'baz', 'name is correct');
176 is($c->value , 'qux', 'value is correct');
177 ok(!defined $c->expires, 'expires is not set');
178 ok(!defined $c->domain , 'domain attributeis not set');
179 is($c->path, '/', 'path atribute is set to default');
180 ok(!defined $c->secure , 'secure attribute is set');
2a1594f6 181 ok( !defined $c->httponly, 'httponly attribute is not set' );
2447c5f5
MS
182
183# I'm really not happy about the restults of this section. You pass
184# the new method invalid arguments and it just merilly creates a
185# broken object :-)
186# I've commented them out because they currently pass but I don't
187# think they should. I think this is testing broken behaviour :-(
188
189# # This shouldn't work
190# $c = CGI::Cookie->new(-name => 'baz' );
191#
192# is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
193# is($c->name , 'baz', 'name is correct');
194# ok(!defined $c->value, "Value is undefined ");
195# ok(!defined $c->expires, 'expires is not set');
196# ok(!defined $c->domain , 'domain attributeis not set');
197# is($c->path , '/', 'path atribute is set to default');
198# ok(!defined $c->secure , 'secure attribute is set');
199
200}
201
202#-----------------------------------------------------------------------------
203# Test as_string
204#-----------------------------------------------------------------------------
205
206{
207 my $c = CGI::Cookie->new(-name => 'Jam',
2a1594f6
CBW
208 -value => 'Hamster',
209 -expires => '+3M',
210 -domain => '.pie-shop.com',
211 -path => '/',
212 -secure => 1,
213 -httponly=> 1
214 );
2447c5f5
MS
215
216 my $name = $c->name;
217 like($c->as_string, "/$name/", "Stringified cookie contains name");
218
219 my $value = $c->value;
220 like($c->as_string, "/$value/", "Stringified cookie contains value");
221
222 my $expires = $c->expires;
223 like($c->as_string, "/$expires/", "Stringified cookie contains expires");
224
225 my $domain = $c->domain;
226 like($c->as_string, "/$domain/", "Stringified cookie contains domain");
227
228 my $path = $c->path;
229 like($c->as_string, "/$path/", "Stringified cookie contains path");
230
231 like($c->as_string, '/secure/', "Stringified cookie contains secure");
232
2a1594f6
CBW
233 like( $c->as_string, '/HttpOnly/',
234 "Stringified cookie contains HttpOnly" );
235
2447c5f5 236 $c = CGI::Cookie->new(-name => 'Hamster-Jam',
2a1594f6
CBW
237 -value => 'Tulip',
238 );
2447c5f5
MS
239
240 $name = $c->name;
241 like($c->as_string, "/$name/", "Stringified cookie contains name");
242
243 $value = $c->value;
244 like($c->as_string, "/$value/", "Stringified cookie contains value");
245
246 ok($c->as_string !~ /expires/, "Stringified cookie has no expires field");
247
248 ok($c->as_string !~ /domain/, "Stringified cookie has no domain field");
249
250 $path = $c->path;
251 like($c->as_string, "/$path/", "Stringified cookie contains path");
252
253 ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure");
2a1594f6
CBW
254
255 ok( $c->as_string !~ /HttpOnly/,
256 "Stringified cookie does not contain HttpOnly" );
2447c5f5
MS
257}
258
259#-----------------------------------------------------------------------------
260# Test compare
261#-----------------------------------------------------------------------------
262
263{
264 my $c1 = CGI::Cookie->new(-name => 'Jam',
2a1594f6
CBW
265 -value => 'Hamster',
266 -expires => '+3M',
267 -domain => '.pie-shop.com',
268 -path => '/',
269 -secure => 1
270 );
2447c5f5
MS
271
272 # have to use $c1->expires because the time will occasionally be
273 # different between the two creates causing spurious failures.
274 my $c2 = CGI::Cookie->new(-name => 'Jam',
2a1594f6
CBW
275 -value => 'Hamster',
276 -expires => $c1->expires,
277 -domain => '.pie-shop.com',
278 -path => '/',
279 -secure => 1
280 );
2447c5f5
MS
281
282 # This looks titally whacked, but it does the -1, 0, 1 comparison
283 # thing so 0 means they match
284 is($c1->compare("$c1"), 0, "Cookies are identical");
2a1594f6 285 is( "$c1", "$c2", "Cookies are identical");
2447c5f5
MS
286
287 $c1 = CGI::Cookie->new(-name => 'Jam',
2a1594f6
CBW
288 -value => 'Hamster',
289 -domain => '.foo.bar.com'
290 );
2447c5f5
MS
291
292 # have to use $c1->expires because the time will occasionally be
293 # different between the two creates causing spurious failures.
294 $c2 = CGI::Cookie->new(-name => 'Jam',
2a1594f6
CBW
295 -value => 'Hamster',
296 );
2447c5f5
MS
297
298 # This looks titally whacked, but it does the -1, 0, 1 comparison
299 # thing so 0 (i.e. false) means they match
300 is($c1->compare("$c1"), 0, "Cookies are identical");
301 ok($c1->compare("$c2"), "Cookies are not identical");
302
303 $c2->domain('.foo.bar.com');
304 is($c1->compare("$c2"), 0, "Cookies are identical");
305}
306
307#-----------------------------------------------------------------------------
308# Test name, value, domain, secure, expires and path
309#-----------------------------------------------------------------------------
310
311{
312 my $c = CGI::Cookie->new(-name => 'Jam',
2a1594f6
CBW
313 -value => 'Hamster',
314 -expires => '+3M',
315 -domain => '.pie-shop.com',
316 -path => '/',
317 -secure => 1
318 );
2447c5f5
MS
319
320 is($c->name, 'Jam', 'name is correct');
321 is($c->name('Clash'), 'Clash', 'name is set correctly');
322 is($c->name, 'Clash', 'name now returns updated value');
323
324 # this is insane! it returns a simple scalar but can't accept one as
325 # an argument, you have to give it an arrary ref. It's totally
326 # inconsitent with these other methods :-(
327 is($c->value, 'Hamster', 'value is correct');
328 is($c->value(['Gerbil']), 'Gerbil', 'value is set correctly');
329 is($c->value, 'Gerbil', 'value now returns updated value');
330
331 my $exp = $c->expires;
332 like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is correct');
333 like($c->expires('+12h'), '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is set correctly');
334 like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires now returns updated value');
335 isnt($c->expires, $exp, "Expiry time has changed");
336
337 is($c->domain, '.pie-shop.com', 'domain is correct');
338 is($c->domain('.wibble.co.uk'), '.wibble.co.uk', 'domain is set correctly');
339 is($c->domain, '.wibble.co.uk', 'domain now returns updated value');
340
341 is($c->path, '/', 'path is correct');
342 is($c->path('/basket/'), '/basket/', 'path is set correctly');
343 is($c->path, '/basket/', 'path now returns updated value');
344
345 ok($c->secure, 'secure attribute is set');
346 ok(!$c->secure(0), 'secure attribute is cleared');
347 ok(!$c->secure, 'secure attribute is cleared');
348}
55b5d700 349
2a1594f6
CBW
350#----------------------------------------------------------------------------
351# Max-age
352#----------------------------------------------------------------------------
353
354MAX_AGE: {
355 my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',);
356 is $cookie->expires, 'Thu, 01-Jan-1970 00:01:40 GMT';
357 is $cookie->max_age => undef, 'max-age is undefined when setting expires';
358
698bc959 359 $cookie = CGI::Cookie->new( -name=>'a', 'value'=>'b' );
2a1594f6
CBW
360 $cookie->max_age( '+4d' );
361
362 is $cookie->expires, undef, 'expires is undef when setting max_age';
363 is $cookie->max_age => 4*24*60*60, 'setting via max-age';
364
365 $cookie->max_age( '113' );
366 is $cookie->max_age => 13, 'max_age(num) as delta';
367}
368
369
370#----------------------------------------------------------------------------
371# bake
372#----------------------------------------------------------------------------
373
374BAKE: {
375 my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',);
376 eval { $cookie->bake };
377 is($@,'', "calling bake() without mod_perl should survive");
378}
379
55b5d700
SP
380#-----------------------------------------------------------------------------
381# Apache2?::Cookie compatibility.
382#-----------------------------------------------------------------------------
383APACHEREQ: {
384 my $r = Apache::Faker->new;
385 isa_ok $r, 'Apache';
386 ok my $c = CGI::Cookie->new(
387 $r,
388 -name => 'Foo',
389 -value => 'Bar',
390 ), 'Pass an Apache object to the CGI::Cookie constructor';
391 isa_ok $c, 'CGI::Cookie';
392 ok $c->bake($r), 'Bake the cookie';
393 ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
394 'bake() should call headers_out->set()';
395
396 $r = Apache2::Faker->new;
397 isa_ok $r, 'Apache2::RequestReq';
398 ok $c = CGI::Cookie->new(
399 $r,
400 -name => 'Foo',
401 -value => 'Bar',
402 ), 'Pass an Apache::RequestReq object to the CGI::Cookie constructor';
403 isa_ok $c, 'CGI::Cookie';
404 ok $c->bake($r), 'Bake the cookie';
405 ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
406 'bake() should call headers_out->set()';
407}
408
409
410package Apache::Faker;
411sub new { bless {}, shift }
412sub isa {
413 my ($self, $pkg) = @_;
414 return $pkg eq 'Apache';
415}
416sub headers_out { shift }
adb86593 417sub add { shift->{check} = \@_; }
55b5d700
SP
418
419package Apache2::Faker;
420sub new { bless {}, shift }
421sub isa {
422 my ($self, $pkg) = @_;
423 return $pkg eq 'Apache2::RequestReq';
424}
425sub headers_out { shift }
adb86593 426sub add { shift->{check} = \@_; }