Upgrade to CGI.pm-3.48
[perl.git] / cpan / CGI / t / cookie.t
1 #!/usr/local/bin/perl -w
2
3 use strict;
4
5 use Test::More tests => 96;
6 use CGI::Util qw(escape unescape);
7 use POSIX qw(strftime);
8
9 #-----------------------------------------------------------------------------
10 # make sure module loaded
11 #-----------------------------------------------------------------------------
12
13 BEGIN {use_ok('CGI::Cookie');}
14
15 my @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 }
323
324 #-----------------------------------------------------------------------------
325 # Apache2?::Cookie compatibility.
326 #-----------------------------------------------------------------------------
327 APACHEREQ: {
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
354 package Apache::Faker;
355 sub new { bless {}, shift }
356 sub isa {
357     my ($self, $pkg) = @_;
358     return $pkg eq 'Apache';
359 }
360 sub headers_out { shift }
361 sub add { shift->{check} = \@_; }
362
363 package Apache2::Faker;
364 sub new { bless {}, shift }
365 sub isa {
366     my ($self, $pkg) = @_;
367     return $pkg eq 'Apache2::RequestReq';
368 }
369 sub headers_out { shift }
370 sub add { shift->{check} = \@_; }