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