File Coverage

blib/lib/Dancer/Cookies.pm

Criterion	Covered	Total	%
statement	42	42	100.0
branch	10	12	83.3
condition	5	6	83.3
subroutine	11	11	100.0
pod	4	6	66.6
total	72	77	93.5

package Dancer::Cookies;
our $AUTHORITY = 'cpan:SUKRIA';
#ABSTRACT: a singleton storage for all cookies
$Dancer::Cookies::VERSION = '1.3514_04'; # TRIAL
$Dancer::Cookies::VERSION = '1.351404';
use strict;
use warnings;

use Dancer::Cookie;
use Dancer::SharedData;

use URI::Escape;

# all cookies defined by the application are store in that singleton
# this is a hashref the represent all key/value pairs to store as cookies
my $COOKIES = {};
sub cookies {$COOKIES}

sub init {
    $COOKIES = parse_cookie_from_env();
}

sub cookie {
    my $class = shift;
    my $name  = shift;
    my $value = shift;
    defined $value && set_cookie( $class, $name, $value, @_ );
    cookies->{$name} ? cookies->{$name}->value : undef;
}

sub parse_cookie_from_env {
    my $request = Dancer::SharedData->request;
    my $env     = (defined $request) ? $request->env : {};
    my $env_str = $env->{COOKIE} || $env->{HTTP_COOKIE};
    return {} unless defined $env_str;

    my $cookies = {};
    foreach my $cookie ( split( /[,;]\s?/, $env_str ) ) {
        # here, we don't want more than the 2 first elements
        # a cookie string can contains something like:
        # cookie_name="foo=bar"
        # we want `cookie_name' as the value and `foo=bar' as the value
        my( $name, $value ) = split /\s*=\s*/, $cookie, 2;

        # catch weird entries like 'cookie1=foo;;cookie2=bar'
        next unless length $name;

        my @values;
        if ( defined $value && $value ne '' ) {
            @values = map { uri_unescape($_) } split( /[&;]/, $value );
        }

        $cookies->{$name} =
          Dancer::Cookie->new( name => $name, value => \@values );
    }

    return $cookies;
}

# set_cookie name => value,
#     expires => time() + 3600, domain => '.foo.com'
#     http_only => 0 # defaults to 1
sub set_cookie {
    my ( $class, $name, $value, %options ) = @_;
    my $cookie =  Dancer::Cookie->new(
        name  => $name,
        value => $value,
        %options
    );
    Dancer::Cookies->set_cookie_object($name => $cookie);
}

sub set_cookie_object {
    my ($class, $name, $cookie) = @_;
    Dancer::SharedData->response->add_cookie($name, $cookie);
    Dancer::Cookies->cookies->{$name} = $cookie;
}

1;

__END__