Upgrade to CGI-3.16, with version bump on CGI.pm for documentation
[perl.git] / lib / CGI / t / cookie.t
1 #!/usr/local/bin/perl -w
2
3 use lib qw(t/lib);
4 use 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
8 use lib qw(blib/lib blib/arch);
9
10 use Test::More tests => 96;
11 use CGI::Util qw(escape unescape);
12 use POSIX qw(strftime);
13
14 #-----------------------------------------------------------------------------
15 # make sure module loaded
16 #-----------------------------------------------------------------------------
17
18 BEGIN {use_ok('CGI::Cookie');}
19
20 my @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 }
328
329 #-----------------------------------------------------------------------------
330 # Apache2?::Cookie compatibility.
331 #-----------------------------------------------------------------------------
332 APACHEREQ: {
333     my $r = Apache::Faker->new;
334     isa_ok $r, 'Apache';
335     ok my $c = CGI::Cookie->new(
336         $r,
337         -name  => 'Foo',
338         -value => 'Bar',
339     ), 'Pass an Apache object to the CGI::Cookie constructor';
340     isa_ok $c, 'CGI::Cookie';
341     ok $c->bake($r), 'Bake the cookie';
342     ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
343         'bake() should call headers_out->set()';
344
345     $r = Apache2::Faker->new;
346     isa_ok $r, 'Apache2::RequestReq';
347     ok $c = CGI::Cookie->new(
348         $r,
349         -name  => 'Foo',
350         -value => 'Bar',
351     ), 'Pass an Apache::RequestReq object to the CGI::Cookie constructor';
352     isa_ok $c, 'CGI::Cookie';
353     ok $c->bake($r), 'Bake the cookie';
354     ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
355         'bake() should call headers_out->set()';
356 }
357
358
359 package Apache::Faker;
360 sub new { bless {}, shift }
361 sub isa {
362     my ($self, $pkg) = @_;
363     return $pkg eq 'Apache';
364 }
365 sub headers_out { shift }
366 sub set { shift->{check} = \@_; }
367
368 package Apache2::Faker;
369 sub new { bless {}, shift }
370 sub isa {
371     my ($self, $pkg) = @_;
372     return $pkg eq 'Apache2::RequestReq';
373 }
374 sub headers_out { shift }
375 sub set { shift->{check} = \@_; }