view release on metacpan or  search on metacpan

t/response/TestCGI/cookie.pm  view on Meta::CPAN

package TestCGI::cookie;

use strict;
use warnings FATAL => 'all';

use CGI::Apache2::Wrapper ();
use CGI::Apache2::Wrapper::Cookie ();

use Apache2::Const -compile => qw(OK);
use Apache2::RequestRec;
use Apache2::RequestIO;

sub handler {
    my $r = shift;
    my $cgi = CGI::Apache2::Wrapper->new($r);
    my $req = $cgi->req;
    my %cookies = CGI::Apache2::Wrapper::Cookie->fetch($r);

    my $test = $cgi->param('test');
    my $key  = $cgi->param('key');

    if ($test eq 'cookies') {

        if ($key eq 'first') {
            my $value = $cgi->cookie('one');
            $r->print($value);
        }
        elsif ($key eq 'two') {
            my $value = $cgi->cookie('two');
            $r->print($value);
        }
        else {
            my @names = $cgi->cookie();
            $r->print(join ' ', map { $_ } sort @names);
        }
    }
    elsif ($test eq 'overload') {
        $r->print($cookies{one});
    }
    elsif ($key and $cookies{$key}) {
        if ($test eq "bake") {
            $cookies{$key}->bake($r);
        }
        elsif ($test eq "bake2") {
            $cookies{$key}->bake2($r);
        }
        $r->print($cookies{$key}->value);
    }
    else {
        my @expires;
        @expires = ("expires", $cgi->param('expires'))
	  if $cgi->param('expires');
        my $cookie = CGI::Apache2::Wrapper::Cookie->new($r, 
							name => "foo",
							value => $test,
							domain => "example.com",
							path => "/quux",
							@expires);
        if ($test eq "bake" or $test eq "") {
            $cookie->bake($req);
        }
        $r->print($cookie->value);
    }


    return Apache2::Const::OK;
}

1;

__END__