=head1 NAME


Apache::Perl::Cookie - interface to Netscape Cookies

=head1 SYNOPSIS

    use Apache::Perl::Cookie;

    my %cookies = Apache::Perl::Cookie->fetch;

    $cookie = Apache::Perl::Cookie->new(-name => 'ID',
                                        -value => 1234);
    $cookie->bake;

=head1 DESCRIPTION

Apache::Perl::Cookie is subclass of L<CGI::Cookie|CGI::Cookie>. It
uses Apache request object instead of enviroment variables to get
existing cookies. Also it adds method for sending cookies using Apache
request object.

Note that this module serves as example only. In real mod_perl
programs you more likely to find L<Apache::Cookie|Apache::Cookie>
module useful.

=head1 BUGS AND LIMITATIONS

This module relies on mod_perl API so it cannot be used in
non-mod_perl environment.

=head1 SEE ALSO

L<Apache|Apache>

L<Apache::Cookie|Apache::Cookie>

L<CGI::Cookie|CGI::Cookie>

=cut

package Apache::Perl::Cookie;

use strict;
use warnings;

use base qw(CGI::Cookie);

sub fetch {
    my $class = shift;

    my $header = Apache->request->header_in('Cookie');

    if(defined $header) {
        return CGI::Cookie->parse($header);
    }

    return;
}

sub bake {
    my $self = shift;

    Apache->request->headers_out->add('Set-Cookie' => $self);
}

1;

##</code><code>##

package Apache;

sub request {
    my $class = shift;
    return bless {}, $class;
}

sub header_in {
....
....
....

##</code><code>##

use Test::More tests => 9;

use strict;
use warnings;

use Test::MockObject;

# build mod_perl interface emulation
my $COOKIE_HEADER_IN;
my $COOKIE_HEADER_OUT;
{
    my $headers_out = Test::MockObject->new;
    my $request     = Test::MockObject->new;

    # Create 'request' method in package Apache which always returns
    # same fake request object $request.
    Test::MockObject->fake_module('Apache',
                                  request => sub { $request });

    # Add 'header_in' method which returns value of $COOKIE_HEADER_IN
    # variable when asked for 'Cookie' header.
    $request->mock('header_in',
                   sub {
                       my ($self, $name) = @_;
                       return $COOKIE_HEADER_IN if $name eq 'Cookie';
                       return;
                   });
    # Add 'header_out' method which always return fake Apache::Table
    # object $headers_out.
    $request->set_always('headers_out', $headers_out);

    # Add 'add' method which stores passed header value in
    # $COOKIE_HEADER_OUT variable for 'Set-Cookie' header.
    $headers_out->mock('add',
                       sub {
                           my ($self, $name, $value) = @_;
                           return unless $name eq 'Set-Cookie';
                           $COOKIE_HEADER_OUT = $value;
                       });
}

# test if we can load module
require_ok 'Apache::Perl::Cookie';

{
    # scenario #1 - no cookie header
    $COOKIE_HEADER_IN = undef;
    my %cookies = Apache::Perl::Cookie->fetch;
    is(scalar(keys %cookies), 0,
       'No cookie header - no cookies are expected');
}

{
    # scenario #2 - empty cookie header
    $COOKIE_HEADER_IN = '';
    my %cookies = Apache::Perl::Cookie->fetch;
    is(scalar(keys %cookies), 0,
       'Empty cookie header - no cookies are expected');
}

{
    # scenario #3 - cookie header with one cookie
    $COOKIE_HEADER_IN = 'Name=Value';
    my %cookies = Apache::Perl::Cookie->fetch;
    is(scalar(keys %cookies), 1, 'One cookie is expected');
    is($cookies{Name}->value, 'Value');
}

{
    # scenario #4 - cookie header with two cookies
    $COOKIE_HEADER_IN = 'Name1=Value1; Name2=Value2';
    my %cookies = Apache::Perl::Cookie->fetch;
    is(scalar(keys %cookies), 2, 'Two cookies are expected');
    is($cookies{Name1}->value, 'Value1');
    is($cookies{Name2}->value, 'Value2');
}

{
    # scenario #5 - send cookie
    my $cookie = Apache::Perl::Cookie->new(-name => 'ID',
                                           -value => 1234);
    $cookie->bake;
    is($COOKIE_HEADER_OUT, 'ID=1234; path=/',
       'Test if cookie have been sent correctly');
}