This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update CGI to CPAN version 3.51
[perl5.git] / cpan / CGI / t / cookie.t
1 #!perl -w
2
3 use strict;
4
5 # to have a consistent baseline, we nail the current time
6 # to 100 seconds after the epoch
7 BEGIN {
8     *CORE::GLOBAL::time = sub { 100 };
9 }
10
11 use Test::More 'no_plan';
12 use CGI::Util qw(escape unescape);
13 use POSIX qw(strftime);
14 use CGI::Cookie;
15
16 #-----------------------------------------------------------------------------
17 # make sure module loaded
18 #-----------------------------------------------------------------------------
19
20 my @test_cookie = (
21            # including leading and trailing whitespace in first cookie
22            ' foo=123 ; bar=qwerty; baz=wibble; qux=a1',
23            'foo=123; bar=qwerty; baz=wibble;',
24            'foo=vixen; bar=cow; baz=bitch; qux=politician',
25            'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27',
26            );
27
28 #-----------------------------------------------------------------------------
29 # Test parse
30 #-----------------------------------------------------------------------------
31
32 {
33   my $result = CGI::Cookie->parse($test_cookie[0]);
34   is(ref($result), 'HASH', "Hash ref returned in scalar context");
35
36   my @result = CGI::Cookie->parse($test_cookie[0]);
37   is(@result, 8, "returns correct number of fields");
38
39   @result = CGI::Cookie->parse($test_cookie[1]);
40   is(@result, 6, "returns correct number of fields");
41
42   my %result = CGI::Cookie->parse($test_cookie[0]);
43   is($result{foo}->value, '123', "cookie foo is correct");
44   is($result{bar}->value, 'qwerty', "cookie bar is correct");
45   is($result{baz}->value, 'wibble', "cookie baz is correct");
46   is($result{qux}->value, 'a1', "cookie qux is correct");
47
48   my @array   = CGI::Cookie->parse('');
49   my $scalar  = CGI::Cookie->parse('');
50   is_deeply(\@array, [], " parse('') returns an empty array   in list context   (undocumented)");
51   is_deeply($scalar, {}, " parse('') returns an empty hashref in scalar context (undocumented)");
52
53   my @array   = CGI::Cookie->parse(undef);
54   my $scalar  = CGI::Cookie->parse(undef);
55   is_deeply(\@array, [], " parse(undef) returns an empty array   in list context   (undocumented)");
56   is_deeply($scalar, {}, " parse(undef) returns an empty hashref in scalar context (undocumented)");
57 }
58
59 #-----------------------------------------------------------------------------
60 # Test fetch
61 #-----------------------------------------------------------------------------
62
63 {
64   # make sure there are no cookies in the environment
65   delete $ENV{HTTP_COOKIE};
66   delete $ENV{COOKIE};
67
68   my %result = CGI::Cookie->fetch();
69   ok(keys %result == 0, "No cookies in environment, returns empty list");
70
71   # now set a cookie in the environment and try again
72   $ENV{HTTP_COOKIE} = $test_cookie[2];
73   %result = CGI::Cookie->fetch();
74   ok(eq_set([keys %result], [qw(foo bar baz qux)]),
75      "expected cookies extracted");
76
77   is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
78   is($result{foo}->value, 'vixen',      "cookie foo is correct");
79   is($result{bar}->value, 'cow',        "cookie bar is correct");
80   is($result{baz}->value, 'bitch',      "cookie baz is correct");
81   is($result{qux}->value, 'politician', "cookie qux is correct");
82
83   # Delete that and make sure it goes away
84   delete $ENV{HTTP_COOKIE};
85   %result = CGI::Cookie->fetch();
86   ok(keys %result == 0, "No cookies in environment, returns empty list");
87
88   # try another cookie in the other environment variable thats supposed to work
89   $ENV{COOKIE} = $test_cookie[3];
90   %result = CGI::Cookie->fetch();
91   ok(eq_set([keys %result], [qw(foo bar baz qux)]),
92      "expected cookies extracted");
93
94   is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
95   is($result{foo}->value, 'a phrase', "cookie foo is correct");
96   is($result{bar}->value, 'yes, a phrase', "cookie bar is correct");
97   is($result{baz}->value, '^wibble', "cookie baz is correct");
98   is($result{qux}->value, "'", "cookie qux is correct");
99 }
100
101 #-----------------------------------------------------------------------------
102 # Test raw_fetch
103 #-----------------------------------------------------------------------------
104
105 {
106   # make sure there are no cookies in the environment
107   delete $ENV{HTTP_COOKIE};
108   delete $ENV{COOKIE};
109
110   my %result = CGI::Cookie->raw_fetch();
111   ok(keys %result == 0, "No cookies in environment, returns empty list");
112
113   # now set a cookie in the environment and try again
114   $ENV{HTTP_COOKIE} = $test_cookie[2];
115   %result = CGI::Cookie->raw_fetch();
116   ok(eq_set([keys %result], [qw(foo bar baz qux)]),
117      "expected cookies extracted");
118
119   is(ref($result{foo}), '', 'Plain scalar returned');
120   is($result{foo}, 'vixen',      "cookie foo is correct");
121   is($result{bar}, 'cow',        "cookie bar is correct");
122   is($result{baz}, 'bitch',      "cookie baz is correct");
123   is($result{qux}, 'politician', "cookie qux is correct");
124
125   # Delete that and make sure it goes away
126   delete $ENV{HTTP_COOKIE};
127   %result = CGI::Cookie->raw_fetch();
128   ok(keys %result == 0, "No cookies in environment, returns empty list");
129
130   # try another cookie in the other environment variable thats supposed to work
131   $ENV{COOKIE} = $test_cookie[3];
132   %result = CGI::Cookie->raw_fetch();
133   ok(eq_set([keys %result], [qw(foo bar baz qux)]),
134      "expected cookies extracted");
135
136   is(ref($result{foo}), '', 'Plain scalar returned');
137   is($result{foo}, 'a%20phrase', "cookie foo is correct");
138   is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct");
139   is($result{baz}, '%5Ewibble', "cookie baz is correct");
140   is($result{qux}, '%27', "cookie qux is correct");
141
142   $ENV{COOKIE} = '$Version=1; foo; $Path="/test"';
143   %result = CGI::Cookie->raw_fetch();
144   is($result{foo}, '', 'no value translates to empty string');
145 }
146
147 #-----------------------------------------------------------------------------
148 # Test new
149 #-----------------------------------------------------------------------------
150
151 {
152   # Try new with full information provided
153   my $c = CGI::Cookie->new(-name    => 'foo',
154                -value   => 'bar',
155                -expires => '+3M',
156                -domain  => '.capricorn.com',
157                -path    => '/cgi-bin/database',
158                -secure  => 1,
159                -httponly=> 1
160               );
161   is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
162   is($c->name   , 'foo',               'name is correct');
163   is($c->value  , 'bar',               'value is correct');
164   like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires in correct format');
165   is($c->domain , '.capricorn.com',    'domain is correct');
166   is($c->path   , '/cgi-bin/database', 'path is correct');
167   ok($c->secure , 'secure attribute is set');
168   ok( $c->httponly, 'httponly attribute is set' );
169
170   # now try it with the only two manditory values (should also set the default path)
171   $c = CGI::Cookie->new(-name    =>  'baz',
172             -value   =>  'qux',
173                );
174   is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
175   is($c->name   , 'baz', 'name is correct');
176   is($c->value  , 'qux', 'value is correct');
177   ok(!defined $c->expires,       'expires is not set');
178   ok(!defined $c->domain ,       'domain attributeis not set');
179   is($c->path, '/',      'path atribute is set to default');
180   ok(!defined $c->secure ,       'secure attribute is set');
181   ok( !defined $c->httponly, 'httponly attribute is not set' );
182
183 # I'm really not happy about the restults of this section.  You pass
184 # the new method invalid arguments and it just merilly creates a
185 # broken object :-)
186 # I've commented them out because they currently pass but I don't
187 # think they should.  I think this is testing broken behaviour :-(
188
189 #    # This shouldn't work
190 #    $c = CGI::Cookie->new(-name => 'baz' );
191 #
192 #    is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
193 #    is($c->name   , 'baz',     'name is correct');
194 #    ok(!defined $c->value, "Value is undefined ");
195 #    ok(!defined $c->expires, 'expires is not set');
196 #    ok(!defined $c->domain , 'domain attributeis not set');
197 #    is($c->path   , '/', 'path atribute is set to default');
198 #    ok(!defined $c->secure , 'secure attribute is set');
199
200 }
201
202 #-----------------------------------------------------------------------------
203 # Test as_string
204 #-----------------------------------------------------------------------------
205
206 {
207   my $c = CGI::Cookie->new(-name    => 'Jam',
208                -value   => 'Hamster',
209                -expires => '+3M',
210                -domain  => '.pie-shop.com',
211                -path    => '/',
212                -secure  => 1,
213                -httponly=> 1
214               );
215
216   my $name = $c->name;
217   like($c->as_string, "/$name/", "Stringified cookie contains name");
218
219   my $value = $c->value;
220   like($c->as_string, "/$value/", "Stringified cookie contains value");
221
222   my $expires = $c->expires;
223   like($c->as_string, "/$expires/", "Stringified cookie contains expires");
224
225   my $domain = $c->domain;
226   like($c->as_string, "/$domain/", "Stringified cookie contains domain");
227
228   my $path = $c->path;
229   like($c->as_string, "/$path/", "Stringified cookie contains path");
230
231   like($c->as_string, '/secure/', "Stringified cookie contains secure");
232
233   like( $c->as_string, '/HttpOnly/',
234     "Stringified cookie contains HttpOnly" );
235
236   $c = CGI::Cookie->new(-name    =>  'Hamster-Jam',
237             -value   =>  'Tulip',
238                );
239
240   $name = $c->name;
241   like($c->as_string, "/$name/", "Stringified cookie contains name");
242
243   $value = $c->value;
244   like($c->as_string, "/$value/", "Stringified cookie contains value");
245
246   ok($c->as_string !~ /expires/, "Stringified cookie has no expires field");
247
248   ok($c->as_string !~ /domain/, "Stringified cookie has no domain field");
249
250   $path = $c->path;
251   like($c->as_string, "/$path/", "Stringified cookie contains path");
252
253   ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure");
254
255   ok( $c->as_string !~ /HttpOnly/,
256     "Stringified cookie does not contain HttpOnly" );
257 }
258
259 #-----------------------------------------------------------------------------
260 # Test compare
261 #-----------------------------------------------------------------------------
262
263 {
264   my $c1 = CGI::Cookie->new(-name    => 'Jam',
265                 -value   => 'Hamster',
266                 -expires => '+3M',
267                 -domain  => '.pie-shop.com',
268                 -path    => '/',
269                 -secure  => 1
270                );
271
272   # have to use $c1->expires because the time will occasionally be
273   # different between the two creates causing spurious failures.
274   my $c2 = CGI::Cookie->new(-name    => 'Jam',
275                 -value   => 'Hamster',
276                 -expires => $c1->expires,
277                 -domain  => '.pie-shop.com',
278                 -path    => '/',
279                 -secure  => 1
280                );
281
282   # This looks titally whacked, but it does the -1, 0, 1 comparison
283   # thing so 0 means they match
284   is($c1->compare("$c1"), 0, "Cookies are identical");
285   is( "$c1", "$c2", "Cookies are identical");
286
287   $c1 = CGI::Cookie->new(-name   => 'Jam',
288              -value  => 'Hamster',
289              -domain => '.foo.bar.com'
290             );
291
292   # have to use $c1->expires because the time will occasionally be
293   # different between the two creates causing spurious failures.
294   $c2 = CGI::Cookie->new(-name    =>  'Jam',
295              -value   =>  'Hamster',
296             );
297
298   # This looks titally whacked, but it does the -1, 0, 1 comparison
299   # thing so 0 (i.e. false) means they match
300   is($c1->compare("$c1"), 0, "Cookies are identical");
301   ok($c1->compare("$c2"), "Cookies are not identical");
302
303   $c2->domain('.foo.bar.com');
304   is($c1->compare("$c2"), 0, "Cookies are identical");
305 }
306
307 #-----------------------------------------------------------------------------
308 # Test name, value, domain, secure, expires and path
309 #-----------------------------------------------------------------------------
310
311 {
312   my $c = CGI::Cookie->new(-name    => 'Jam',
313                -value   => 'Hamster',
314                -expires => '+3M',
315                -domain  => '.pie-shop.com',
316                -path    => '/',
317                -secure  => 1
318                );
319
320   is($c->name,          'Jam',   'name is correct');
321   is($c->name('Clash'), 'Clash', 'name is set correctly');
322   is($c->name,          'Clash', 'name now returns updated value');
323
324   # this is insane!  it returns a simple scalar but can't accept one as
325   # an argument, you have to give it an arrary ref.  It's totally
326   # inconsitent with these other methods :-(
327   is($c->value,           'Hamster', 'value is correct');
328   is($c->value(['Gerbil']), 'Gerbil',  'value is set correctly');
329   is($c->value,           'Gerbil',  'value now returns updated value');
330
331   my $exp = $c->expires;
332   like($c->expires,         '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is correct');
333   like($c->expires('+12h'), '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is set correctly');
334   like($c->expires,         '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires now returns updated value');
335   isnt($c->expires, $exp, "Expiry time has changed");
336
337   is($c->domain,                  '.pie-shop.com', 'domain is correct');
338   is($c->domain('.wibble.co.uk'), '.wibble.co.uk', 'domain is set correctly');
339   is($c->domain,                  '.wibble.co.uk', 'domain now returns updated value');
340
341   is($c->path,             '/',        'path is correct');
342   is($c->path('/basket/'), '/basket/', 'path is set correctly');
343   is($c->path,             '/basket/', 'path now returns updated value');
344
345   ok($c->secure,     'secure attribute is set');
346   ok(!$c->secure(0), 'secure attribute is cleared');
347   ok(!$c->secure,    'secure attribute is cleared');
348 }
349
350 #----------------------------------------------------------------------------
351 # Max-age
352 #----------------------------------------------------------------------------
353
354 MAX_AGE: {
355     my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',);
356     is $cookie->expires, 'Thu, 01-Jan-1970 00:01:40 GMT';
357     is $cookie->max_age => undef, 'max-age is undefined when setting expires';
358
359     my $cookie = CGI::Cookie->new( -name=>'a', 'value'=>'b' );
360     $cookie->max_age( '+4d' );
361
362     is $cookie->expires, undef, 'expires is undef when setting max_age';
363     is $cookie->max_age => 4*24*60*60, 'setting via max-age';
364
365     $cookie->max_age( '113' );
366     is $cookie->max_age => 13, 'max_age(num) as delta';
367 }
368
369
370 #----------------------------------------------------------------------------
371 # bake
372 #----------------------------------------------------------------------------
373
374 BAKE: {
375     my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',);
376     eval { $cookie->bake };
377     is($@,'', "calling bake() without mod_perl should survive"); 
378 }
379
380 #-----------------------------------------------------------------------------
381 # Apache2?::Cookie compatibility.
382 #-----------------------------------------------------------------------------
383 APACHEREQ: {
384     my $r = Apache::Faker->new;
385     isa_ok $r, 'Apache';
386     ok my $c = CGI::Cookie->new(
387         $r,
388         -name  => 'Foo',
389         -value => 'Bar',
390     ), 'Pass an Apache object to the CGI::Cookie constructor';
391     isa_ok $c, 'CGI::Cookie';
392     ok $c->bake($r), 'Bake the cookie';
393     ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
394         'bake() should call headers_out->set()';
395
396     $r = Apache2::Faker->new;
397     isa_ok $r, 'Apache2::RequestReq';
398     ok $c = CGI::Cookie->new(
399         $r,
400         -name  => 'Foo',
401         -value => 'Bar',
402     ), 'Pass an Apache::RequestReq object to the CGI::Cookie constructor';
403     isa_ok $c, 'CGI::Cookie';
404     ok $c->bake($r), 'Bake the cookie';
405     ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
406         'bake() should call headers_out->set()';
407 }
408
409
410 package Apache::Faker;
411 sub new { bless {}, shift }
412 sub isa {
413     my ($self, $pkg) = @_;
414     return $pkg eq 'Apache';
415 }
416 sub headers_out { shift }
417 sub add { shift->{check} = \@_; }
418
419 package Apache2::Faker;
420 sub new { bless {}, shift }
421 sub isa {
422     my ($self, $pkg) = @_;
423     return $pkg eq 'Apache2::RequestReq';
424 }
425 sub headers_out { shift }
426 sub add { shift->{check} = \@_; }