source: trunk/essentials/dev-lang/perl/lib/CGI/t/cookie.t@ 3298

Last change on this file since 3298 was 3181, checked in by bird, 19 years ago

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