[perl5.git] / lib / CGI / t / cookie.t

#!/usr/local/bin/perl -w

use lib qw(t/lib);
use strict;

# Due to a bug in older versions of MakeMaker & Test::Harness, we must
# ensure the blib's are in @INC, else we might use the core CGI.pm
use lib qw(blib/lib blib/arch);

use Test::More tests => 96;
use CGI::Util qw(escape unescape);
use POSIX qw(strftime);

#-----------------------------------------------------------------------------
# make sure module loaded
#-----------------------------------------------------------------------------

BEGIN {use_ok('CGI::Cookie');}

my @test_cookie = (
		   'foo=123; bar=qwerty; baz=wibble; qux=a1',
		   'foo=123; bar=qwerty; baz=wibble;',
		   'foo=vixen; bar=cow; baz=bitch; qux=politician',
		   'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27',
		   );

#-----------------------------------------------------------------------------
# Test parse
#-----------------------------------------------------------------------------

{
  my $result = CGI::Cookie->parse($test_cookie[0]);

  is(ref($result), 'HASH', "Hash ref returned in scalar context");

  my @result = CGI::Cookie->parse($test_cookie[0]);

  is(@result, 8, "returns correct number of fields");

  @result = CGI::Cookie->parse($test_cookie[1]);

  is(@result, 6, "returns correct number of fields");

  my %result = CGI::Cookie->parse($test_cookie[0]);

  is($result{foo}->value, '123', "cookie foo is correct");
  is($result{bar}->value, 'qwerty', "cookie bar is correct");
  is($result{baz}->value, 'wibble', "cookie baz is correct");
  is($result{qux}->value, 'a1', "cookie qux is correct");
}

#-----------------------------------------------------------------------------
# Test fetch
#-----------------------------------------------------------------------------

{
  # make sure there are no cookies in the environment
  delete $ENV{HTTP_COOKIE};
  delete $ENV{COOKIE};

  my %result = CGI::Cookie->fetch();
  ok(keys %result == 0, "No cookies in environment, returns empty list");

  # now set a cookie in the environment and try again
  $ENV{HTTP_COOKIE} = $test_cookie[2];
  %result = CGI::Cookie->fetch();
  ok(eq_set([keys %result], [qw(foo bar baz qux)]),
     "expected cookies extracted");

  is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
  is($result{foo}->value, 'vixen',      "cookie foo is correct");
  is($result{bar}->value, 'cow',        "cookie bar is correct");
  is($result{baz}->value, 'bitch',      "cookie baz is correct");
  is($result{qux}->value, 'politician', "cookie qux is correct");

  # Delete that and make sure it goes away
  delete $ENV{HTTP_COOKIE};
  %result = CGI::Cookie->fetch();
  ok(keys %result == 0, "No cookies in environment, returns empty list");

  # try another cookie in the other environment variable thats supposed to work
  $ENV{COOKIE} = $test_cookie[3];
  %result = CGI::Cookie->fetch();
  ok(eq_set([keys %result], [qw(foo bar baz qux)]),
     "expected cookies extracted");

  is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
  is($result{foo}->value, 'a phrase', "cookie foo is correct");
  is($result{bar}->value, 'yes, a phrase', "cookie bar is correct");
  is($result{baz}->value, '^wibble', "cookie baz is correct");
  is($result{qux}->value, "'", "cookie qux is correct");
}

#-----------------------------------------------------------------------------
# Test raw_fetch
#-----------------------------------------------------------------------------

{
  # make sure there are no cookies in the environment
  delete $ENV{HTTP_COOKIE};
  delete $ENV{COOKIE};

  my %result = CGI::Cookie->raw_fetch();
  ok(keys %result == 0, "No cookies in environment, returns empty list");

  # now set a cookie in the environment and try again
  $ENV{HTTP_COOKIE} = $test_cookie[2];
  %result = CGI::Cookie->raw_fetch();
  ok(eq_set([keys %result], [qw(foo bar baz qux)]),
     "expected cookies extracted");

  is(ref($result{foo}), '', 'Plain scalar returned');
  is($result{foo}, 'vixen',      "cookie foo is correct");
  is($result{bar}, 'cow',        "cookie bar is correct");
  is($result{baz}, 'bitch',      "cookie baz is correct");
  is($result{qux}, 'politician', "cookie qux is correct");

  # Delete that and make sure it goes away
  delete $ENV{HTTP_COOKIE};
  %result = CGI::Cookie->raw_fetch();
  ok(keys %result == 0, "No cookies in environment, returns empty list");

  # try another cookie in the other environment variable thats supposed to work
  $ENV{COOKIE} = $test_cookie[3];
  %result = CGI::Cookie->raw_fetch();
  ok(eq_set([keys %result], [qw(foo bar baz qux)]),
     "expected cookies extracted");

  is(ref($result{foo}), '', 'Plain scalar returned');
  is($result{foo}, 'a%20phrase', "cookie foo is correct");
  is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct");
  is($result{baz}, '%5Ewibble', "cookie baz is correct");
  is($result{qux}, '%27', "cookie qux is correct");
}

#-----------------------------------------------------------------------------
# Test new
#-----------------------------------------------------------------------------

{
  # Try new with full information provided
  my $c = CGI::Cookie->new(-name    => 'foo',
			   -value   => 'bar',
			   -expires => '+3M',
			   -domain  => '.capricorn.com',
			   -path    => '/cgi-bin/database',
			   -secure  => 1
			  );
  is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
  is($c->name   , 'foo',               'name is correct');
  is($c->value  , 'bar',               'value is correct');
  like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires in correct format');
  is($c->domain , '.capricorn.com',    'domain is correct');
  is($c->path   , '/cgi-bin/database', 'path is correct');
  ok($c->secure , 'secure attribute is set');

  # now try it with the only two manditory values (should also set the default path)
  $c = CGI::Cookie->new(-name    =>  'baz',
			-value   =>  'qux',
		       );
  is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
  is($c->name   , 'baz', 'name is correct');
  is($c->value  , 'qux', 'value is correct');
  ok(!defined $c->expires,       'expires is not set');
  ok(!defined $c->domain ,       'domain attributeis not set');
  is($c->path, '/',      'path atribute is set to default');
  ok(!defined $c->secure ,       'secure attribute is set');

# I'm really not happy about the restults of this section.  You pass
# the new method invalid arguments and it just merilly creates a
# broken object :-)
# I've commented them out because they currently pass but I don't
# think they should.  I think this is testing broken behaviour :-(

#    # This shouldn't work
#    $c = CGI::Cookie->new(-name => 'baz' );
#
#    is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
#    is($c->name   , 'baz',     'name is correct');
#    ok(!defined $c->value, "Value is undefined ");
#    ok(!defined $c->expires, 'expires is not set');
#    ok(!defined $c->domain , 'domain attributeis not set');
#    is($c->path   , '/', 'path atribute is set to default');
#    ok(!defined $c->secure , 'secure attribute is set');

}

#-----------------------------------------------------------------------------
# Test as_string
#-----------------------------------------------------------------------------

{
  my $c = CGI::Cookie->new(-name    => 'Jam',
			   -value   => 'Hamster',
			   -expires => '+3M',
			   -domain  => '.pie-shop.com',
			   -path    => '/',
			   -secure  => 1
			  );

  my $name = $c->name;
  like($c->as_string, "/$name/", "Stringified cookie contains name");

  my $value = $c->value;
  like($c->as_string, "/$value/", "Stringified cookie contains value");

  my $expires = $c->expires;
  like($c->as_string, "/$expires/", "Stringified cookie contains expires");

  my $domain = $c->domain;
  like($c->as_string, "/$domain/", "Stringified cookie contains domain");

  my $path = $c->path;
  like($c->as_string, "/$path/", "Stringified cookie contains path");

  like($c->as_string, '/secure/', "Stringified cookie contains secure");

  $c = CGI::Cookie->new(-name    =>  'Hamster-Jam',
			-value   =>  'Tulip',
		       );

  $name = $c->name;
  like($c->as_string, "/$name/", "Stringified cookie contains name");

  $value = $c->value;
  like($c->as_string, "/$value/", "Stringified cookie contains value");

  ok($c->as_string !~ /expires/, "Stringified cookie has no expires field");

  ok($c->as_string !~ /domain/, "Stringified cookie has no domain field");

  $path = $c->path;
  like($c->as_string, "/$path/", "Stringified cookie contains path");

  ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure");
}

#-----------------------------------------------------------------------------
# Test compare
#-----------------------------------------------------------------------------

{
  my $c1 = CGI::Cookie->new(-name    => 'Jam',
			    -value   => 'Hamster',
			    -expires => '+3M',
			    -domain  => '.pie-shop.com',
			    -path    => '/',
			    -secure  => 1
			   );

  # have to use $c1->expires because the time will occasionally be
  # different between the two creates causing spurious failures.
  my $c2 = CGI::Cookie->new(-name    => 'Jam',
			    -value   => 'Hamster',
			    -expires => $c1->expires,
			    -domain  => '.pie-shop.com',
			    -path    => '/',
			    -secure  => 1
			   );

  # This looks titally whacked, but it does the -1, 0, 1 comparison
  # thing so 0 means they match
  is($c1->compare("$c1"), 0, "Cookies are identical");
  is($c1->compare("$c2"), 0, "Cookies are identical");

  $c1 = CGI::Cookie->new(-name   => 'Jam',
			 -value  => 'Hamster',
			 -domain => '.foo.bar.com'
			);

  # have to use $c1->expires because the time will occasionally be
  # different between the two creates causing spurious failures.
  $c2 = CGI::Cookie->new(-name    =>  'Jam',
			 -value   =>  'Hamster',
			);

  # This looks titally whacked, but it does the -1, 0, 1 comparison
  # thing so 0 (i.e. false) means they match
  is($c1->compare("$c1"), 0, "Cookies are identical");
  ok($c1->compare("$c2"), "Cookies are not identical");

  $c2->domain('.foo.bar.com');
  is($c1->compare("$c2"), 0, "Cookies are identical");
}

#-----------------------------------------------------------------------------
# Test name, value, domain, secure, expires and path
#-----------------------------------------------------------------------------

{
  my $c = CGI::Cookie->new(-name    => 'Jam',
			   -value   => 'Hamster',
			   -expires => '+3M',
			   -domain  => '.pie-shop.com',
			   -path    => '/',
			   -secure  => 1
			   );

  is($c->name,          'Jam',   'name is correct');
  is($c->name('Clash'), 'Clash', 'name is set correctly');
  is($c->name,          'Clash', 'name now returns updated value');

  # this is insane!  it returns a simple scalar but can't accept one as
  # an argument, you have to give it an arrary ref.  It's totally
  # inconsitent with these other methods :-(
  is($c->value,           'Hamster', 'value is correct');
  is($c->value(['Gerbil']), 'Gerbil',  'value is set correctly');
  is($c->value,           'Gerbil',  'value now returns updated value');

  my $exp = $c->expires;
  like($c->expires,         '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is correct');
  like($c->expires('+12h'), '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is set correctly');
  like($c->expires,         '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires now returns updated value');
  isnt($c->expires, $exp, "Expiry time has changed");

  is($c->domain,                  '.pie-shop.com', 'domain is correct');
  is($c->domain('.wibble.co.uk'), '.wibble.co.uk', 'domain is set correctly');
  is($c->domain,                  '.wibble.co.uk', 'domain now returns updated value');

  is($c->path,             '/',        'path is correct');
  is($c->path('/basket/'), '/basket/', 'path is set correctly');
  is($c->path,             '/basket/', 'path now returns updated value');

  ok($c->secure,     'secure attribute is set');
  ok(!$c->secure(0), 'secure attribute is cleared');
  ok(!$c->secure,    'secure attribute is cleared');
}

#-----------------------------------------------------------------------------
# Apache2?::Cookie compatibility.
#-----------------------------------------------------------------------------
APACHEREQ: {
    my $r = Apache::Faker->new;
    isa_ok $r, 'Apache';
    ok my $c = CGI::Cookie->new(
        $r,
        -name  => 'Foo',
        -value => 'Bar',
    ), 'Pass an Apache object to the CGI::Cookie constructor';
    isa_ok $c, 'CGI::Cookie';
    ok $c->bake($r), 'Bake the cookie';
    ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
        'bake() should call headers_out->set()';

    $r = Apache2::Faker->new;
    isa_ok $r, 'Apache2::RequestReq';
    ok $c = CGI::Cookie->new(
        $r,
        -name  => 'Foo',
        -value => 'Bar',
    ), 'Pass an Apache::RequestReq object to the CGI::Cookie constructor';
    isa_ok $c, 'CGI::Cookie';
    ok $c->bake($r), 'Bake the cookie';
    ok eq_array( $r->{check}, [ 'Set-Cookie', $c->as_string ]),
        'bake() should call headers_out->set()';
}


package Apache::Faker;
sub new { bless {}, shift }
sub isa {
    my ($self, $pkg) = @_;
    return $pkg eq 'Apache';
}
sub headers_out { shift }
sub add { shift->{check} = \@_; }

package Apache2::Faker;
sub new { bless {}, shift }
sub isa {
    my ($self, $pkg) = @_;
    return $pkg eq 'Apache2::RequestReq';
}
sub headers_out { shift }
sub add { shift->{check} = \@_; }
Commit	Line	Data
2447c5f5 MS	1	#!/usr/local/bin/perl -w
2447c5f5 MS	2
8f3ccfa2	3	use lib qw(t/lib);
2447c5f5	4	use strict;
ac734d8b	5
8f3ccfa2 JH	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
55b5d700	10	use Test::More tests => 96;
2447c5f5 MS	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	}
55b5d700 SP	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 }
adb86593	366	sub add { shift->{check} = \@_; }
55b5d700 SP	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 }
adb86593	375	sub add { shift->{check} = \@_; }