Commit | Line | Data |
---|---|---|
2447c5f5 MS |
1 | #!/usr/local/bin/perl -w |
2 | ||
3 | use strict; | |
4 | use Test::More tests => 86; | |
5 | use CGI::Util qw(escape unescape); | |
6 | use POSIX qw(strftime); | |
7 | ||
8 | #----------------------------------------------------------------------------- | |
9 | # make sure module loaded | |
10 | #----------------------------------------------------------------------------- | |
11 | ||
12 | BEGIN {use_ok('CGI::Cookie');} | |
13 | ||
14 | my @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 | } |