1 #!/usr/local/bin/perl -w
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
8 use lib qw(blib/lib blib/arch);
10 use Test::More tests => 86;
11 use CGI::Util qw(escape unescape);
12 use POSIX qw(strftime);
14 #-----------------------------------------------------------------------------
15 # make sure module loaded
16 #-----------------------------------------------------------------------------
18 BEGIN {use_ok('CGI::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',
27 #-----------------------------------------------------------------------------
29 #-----------------------------------------------------------------------------
32 my $result = CGI::Cookie->parse($test_cookie[0]);
34 is(ref($result), 'HASH', "Hash ref returned in scalar context");
36 my @result = CGI::Cookie->parse($test_cookie[0]);
38 is(@result, 8, "returns correct number of fields");
40 @result = CGI::Cookie->parse($test_cookie[1]);
42 is(@result, 6, "returns correct number of fields");
44 my %result = CGI::Cookie->parse($test_cookie[0]);
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");
52 #-----------------------------------------------------------------------------
54 #-----------------------------------------------------------------------------
57 # make sure there are no cookies in the environment
58 delete $ENV{HTTP_COOKIE};
61 my %result = CGI::Cookie->fetch();
62 ok(keys %result == 0, "No cookies in environment, returns empty list");
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");
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");
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");
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");
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");
94 #-----------------------------------------------------------------------------
96 #-----------------------------------------------------------------------------
99 # make sure there are no cookies in the environment
100 delete $ENV{HTTP_COOKIE};
103 my %result = CGI::Cookie->raw_fetch();
104 ok(keys %result == 0, "No cookies in environment, returns empty list");
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");
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");
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");
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");
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");
136 #-----------------------------------------------------------------------------
138 #-----------------------------------------------------------------------------
141 # Try new with full information provided
142 my $c = CGI::Cookie->new(-name => 'foo',
145 -domain => '.capricorn.com',
146 -path => '/cgi-bin/database',
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');
157 # now try it with the only two manditory values (should also set the default path)
158 $c = CGI::Cookie->new(-name => 'baz',
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');
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
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 :-(
175 # # This shouldn't work
176 # $c = CGI::Cookie->new(-name => 'baz' );
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');
188 #-----------------------------------------------------------------------------
190 #-----------------------------------------------------------------------------
193 my $c = CGI::Cookie->new(-name => 'Jam',
196 -domain => '.pie-shop.com',
202 like($c->as_string, "/$name/", "Stringified cookie contains name");
204 my $value = $c->value;
205 like($c->as_string, "/$value/", "Stringified cookie contains value");
207 my $expires = $c->expires;
208 like($c->as_string, "/$expires/", "Stringified cookie contains expires");
210 my $domain = $c->domain;
211 like($c->as_string, "/$domain/", "Stringified cookie contains domain");
214 like($c->as_string, "/$path/", "Stringified cookie contains path");
216 like($c->as_string, '/secure/', "Stringified cookie contains secure");
218 $c = CGI::Cookie->new(-name => 'Hamster-Jam',
223 like($c->as_string, "/$name/", "Stringified cookie contains name");
226 like($c->as_string, "/$value/", "Stringified cookie contains value");
228 ok($c->as_string !~ /expires/, "Stringified cookie has no expires field");
230 ok($c->as_string !~ /domain/, "Stringified cookie has no domain field");
233 like($c->as_string, "/$path/", "Stringified cookie contains path");
235 ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure");
238 #-----------------------------------------------------------------------------
240 #-----------------------------------------------------------------------------
243 my $c1 = CGI::Cookie->new(-name => 'Jam',
246 -domain => '.pie-shop.com',
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',
255 -expires => $c1->expires,
256 -domain => '.pie-shop.com',
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");
266 $c1 = CGI::Cookie->new(-name => 'Jam',
268 -domain => '.foo.bar.com'
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',
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");
282 $c2->domain('.foo.bar.com');
283 is($c1->compare("$c2"), 0, "Cookies are identical");
286 #-----------------------------------------------------------------------------
287 # Test name, value, domain, secure, expires and path
288 #-----------------------------------------------------------------------------
291 my $c = CGI::Cookie->new(-name => 'Jam',
294 -domain => '.pie-shop.com',
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');
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');
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");
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');
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');
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');