1 #!/usr/local/bin/perl -w
8 # Due to a bug in older versions of MakeMaker & Test::Harness, we must
9 # ensure the blib's are in @INC, else we might use the core CGI.pm
10 unshift @INC, qw( ../blib/lib ../blib/arch lib );
15 use Test::More tests => 86;
16 use CGI::Util qw(escape unescape);
17 use POSIX qw(strftime);
19 #-----------------------------------------------------------------------------
20 # make sure module loaded
21 #-----------------------------------------------------------------------------
23 BEGIN {use_ok('CGI::Cookie');}
26 'foo=123; bar=qwerty; baz=wibble; qux=a1',
27 'foo=123; bar=qwerty; baz=wibble;',
28 'foo=vixen; bar=cow; baz=bitch; qux=politician',
29 'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27',
32 #-----------------------------------------------------------------------------
34 #-----------------------------------------------------------------------------
37 my $result = CGI::Cookie->parse($test_cookie[0]);
39 is(ref($result), 'HASH', "Hash ref returned in scalar context");
41 my @result = CGI::Cookie->parse($test_cookie[0]);
43 is(@result, 8, "returns correct number of fields");
45 @result = CGI::Cookie->parse($test_cookie[1]);
47 is(@result, 6, "returns correct number of fields");
49 my %result = CGI::Cookie->parse($test_cookie[0]);
51 is($result{foo}->value, '123', "cookie foo is correct");
52 is($result{bar}->value, 'qwerty', "cookie bar is correct");
53 is($result{baz}->value, 'wibble', "cookie baz is correct");
54 is($result{qux}->value, 'a1', "cookie qux is correct");
57 #-----------------------------------------------------------------------------
59 #-----------------------------------------------------------------------------
62 # make sure there are no cookies in the environment
63 delete $ENV{HTTP_COOKIE};
66 my %result = CGI::Cookie->fetch();
67 ok(keys %result == 0, "No cookies in environment, returns empty list");
69 # now set a cookie in the environment and try again
70 $ENV{HTTP_COOKIE} = $test_cookie[2];
71 %result = CGI::Cookie->fetch();
72 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
73 "expected cookies extracted");
75 is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
76 is($result{foo}->value, 'vixen', "cookie foo is correct");
77 is($result{bar}->value, 'cow', "cookie bar is correct");
78 is($result{baz}->value, 'bitch', "cookie baz is correct");
79 is($result{qux}->value, 'politician', "cookie qux is correct");
81 # Delete that and make sure it goes away
82 delete $ENV{HTTP_COOKIE};
83 %result = CGI::Cookie->fetch();
84 ok(keys %result == 0, "No cookies in environment, returns empty list");
86 # try another cookie in the other environment variable thats supposed to work
87 $ENV{COOKIE} = $test_cookie[3];
88 %result = CGI::Cookie->fetch();
89 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
90 "expected cookies extracted");
92 is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
93 is($result{foo}->value, 'a phrase', "cookie foo is correct");
94 is($result{bar}->value, 'yes, a phrase', "cookie bar is correct");
95 is($result{baz}->value, '^wibble', "cookie baz is correct");
96 is($result{qux}->value, "'", "cookie qux is correct");
99 #-----------------------------------------------------------------------------
101 #-----------------------------------------------------------------------------
104 # make sure there are no cookies in the environment
105 delete $ENV{HTTP_COOKIE};
108 my %result = CGI::Cookie->raw_fetch();
109 ok(keys %result == 0, "No cookies in environment, returns empty list");
111 # now set a cookie in the environment and try again
112 $ENV{HTTP_COOKIE} = $test_cookie[2];
113 %result = CGI::Cookie->raw_fetch();
114 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
115 "expected cookies extracted");
117 is(ref($result{foo}), '', 'Plain scalar returned');
118 is($result{foo}, 'vixen', "cookie foo is correct");
119 is($result{bar}, 'cow', "cookie bar is correct");
120 is($result{baz}, 'bitch', "cookie baz is correct");
121 is($result{qux}, 'politician', "cookie qux is correct");
123 # Delete that and make sure it goes away
124 delete $ENV{HTTP_COOKIE};
125 %result = CGI::Cookie->raw_fetch();
126 ok(keys %result == 0, "No cookies in environment, returns empty list");
128 # try another cookie in the other environment variable thats supposed to work
129 $ENV{COOKIE} = $test_cookie[3];
130 %result = CGI::Cookie->raw_fetch();
131 ok(eq_set([keys %result], [qw(foo bar baz qux)]),
132 "expected cookies extracted");
134 is(ref($result{foo}), '', 'Plain scalar returned');
135 is($result{foo}, 'a%20phrase', "cookie foo is correct");
136 is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct");
137 is($result{baz}, '%5Ewibble', "cookie baz is correct");
138 is($result{qux}, '%27', "cookie qux is correct");
141 #-----------------------------------------------------------------------------
143 #-----------------------------------------------------------------------------
146 # Try new with full information provided
147 my $c = CGI::Cookie->new(-name => 'foo',
150 -domain => '.capricorn.com',
151 -path => '/cgi-bin/database',
154 is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
155 is($c->name , 'foo', 'name is correct');
156 is($c->value , 'bar', 'value is correct');
157 like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires in correct format');
158 is($c->domain , '.capricorn.com', 'domain is correct');
159 is($c->path , '/cgi-bin/database', 'path is correct');
160 ok($c->secure , 'secure attribute is set');
162 # now try it with the only two manditory values (should also set the default path)
163 $c = CGI::Cookie->new(-name => 'baz',
166 is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
167 is($c->name , 'baz', 'name is correct');
168 is($c->value , 'qux', 'value is correct');
169 ok(!defined $c->expires, 'expires is not set');
170 ok(!defined $c->domain , 'domain attributeis not set');
171 is($c->path, '/', 'path atribute is set to default');
172 ok(!defined $c->secure , 'secure attribute is set');
174 # I'm really not happy about the restults of this section. You pass
175 # the new method invalid arguments and it just merilly creates a
177 # I've commented them out because they currently pass but I don't
178 # think they should. I think this is testing broken behaviour :-(
180 # # This shouldn't work
181 # $c = CGI::Cookie->new(-name => 'baz' );
183 # is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
184 # is($c->name , 'baz', 'name is correct');
185 # ok(!defined $c->value, "Value is undefined ");
186 # ok(!defined $c->expires, 'expires is not set');
187 # ok(!defined $c->domain , 'domain attributeis not set');
188 # is($c->path , '/', 'path atribute is set to default');
189 # ok(!defined $c->secure , 'secure attribute is set');
193 #-----------------------------------------------------------------------------
195 #-----------------------------------------------------------------------------
198 my $c = CGI::Cookie->new(-name => 'Jam',
201 -domain => '.pie-shop.com',
207 like($c->as_string, "/$name/", "Stringified cookie contains name");
209 my $value = $c->value;
210 like($c->as_string, "/$value/", "Stringified cookie contains value");
212 my $expires = $c->expires;
213 like($c->as_string, "/$expires/", "Stringified cookie contains expires");
215 my $domain = $c->domain;
216 like($c->as_string, "/$domain/", "Stringified cookie contains domain");
219 like($c->as_string, "/$path/", "Stringified cookie contains path");
221 like($c->as_string, '/secure/', "Stringified cookie contains secure");
223 $c = CGI::Cookie->new(-name => 'Hamster-Jam',
228 like($c->as_string, "/$name/", "Stringified cookie contains name");
231 like($c->as_string, "/$value/", "Stringified cookie contains value");
233 ok($c->as_string !~ /expires/, "Stringified cookie has no expires field");
235 ok($c->as_string !~ /domain/, "Stringified cookie has no domain field");
238 like($c->as_string, "/$path/", "Stringified cookie contains path");
240 ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure");
243 #-----------------------------------------------------------------------------
245 #-----------------------------------------------------------------------------
248 my $c1 = CGI::Cookie->new(-name => 'Jam',
251 -domain => '.pie-shop.com',
256 # have to use $c1->expires because the time will occasionally be
257 # different between the two creates causing spurious failures.
258 my $c2 = CGI::Cookie->new(-name => 'Jam',
260 -expires => $c1->expires,
261 -domain => '.pie-shop.com',
266 # This looks titally whacked, but it does the -1, 0, 1 comparison
267 # thing so 0 means they match
268 is($c1->compare("$c1"), 0, "Cookies are identical");
269 is($c1->compare("$c2"), 0, "Cookies are identical");
271 $c1 = CGI::Cookie->new(-name => 'Jam',
273 -domain => '.foo.bar.com'
276 # have to use $c1->expires because the time will occasionally be
277 # different between the two creates causing spurious failures.
278 $c2 = CGI::Cookie->new(-name => 'Jam',
282 # This looks titally whacked, but it does the -1, 0, 1 comparison
283 # thing so 0 (i.e. false) means they match
284 is($c1->compare("$c1"), 0, "Cookies are identical");
285 ok($c1->compare("$c2"), "Cookies are not identical");
287 $c2->domain('.foo.bar.com');
288 is($c1->compare("$c2"), 0, "Cookies are identical");
291 #-----------------------------------------------------------------------------
292 # Test name, value, domain, secure, expires and path
293 #-----------------------------------------------------------------------------
296 my $c = CGI::Cookie->new(-name => 'Jam',
299 -domain => '.pie-shop.com',
304 is($c->name, 'Jam', 'name is correct');
305 is($c->name('Clash'), 'Clash', 'name is set correctly');
306 is($c->name, 'Clash', 'name now returns updated value');
308 # this is insane! it returns a simple scalar but can't accept one as
309 # an argument, you have to give it an arrary ref. It's totally
310 # inconsitent with these other methods :-(
311 is($c->value, 'Hamster', 'value is correct');
312 is($c->value(['Gerbil']), 'Gerbil', 'value is set correctly');
313 is($c->value, 'Gerbil', 'value now returns updated value');
315 my $exp = $c->expires;
316 like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is correct');
317 like($c->expires('+12h'), '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is set correctly');
318 like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires now returns updated value');
319 isnt($c->expires, $exp, "Expiry time has changed");
321 is($c->domain, '.pie-shop.com', 'domain is correct');
322 is($c->domain('.wibble.co.uk'), '.wibble.co.uk', 'domain is set correctly');
323 is($c->domain, '.wibble.co.uk', 'domain now returns updated value');
325 is($c->path, '/', 'path is correct');
326 is($c->path('/basket/'), '/basket/', 'path is set correctly');
327 is($c->path, '/basket/', 'path now returns updated value');
329 ok($c->secure, 'secure attribute is set');
330 ok(!$c->secure(0), 'secure attribute is cleared');
331 ok(!$c->secure, 'secure attribute is cleared');