File Coverage

blib/lib/Dancer2/Core/Cookie.pm

Criterion	Covered	Total	%
statement	48	49	97.9
branch	19	26	73.0
condition	2	3	66.6
subroutine	12	12	100.0
pod	1	3	33.3
total	82	93	88.1

package Dancer2::Core::Cookie;
# ABSTRACT: A cookie representing class
$Dancer2::Core::Cookie::VERSION = '2.1.0';
use Moo;
use URI::Escape;
use Dancer2::Core::Types;
use Dancer2::Core::Time;
use Carp 'croak';
use Ref::Util qw< is_arrayref is_hashref >;
use overload '""' => \&_get_value;

BEGIN {
    my $try_xs =
        exists($ENV{PERL_HTTP_XSCOOKIES}) ? !!$ENV{PERL_HTTP_XSCOOKIES} :
        exists($ENV{PERL_ONLY})           ?  !$ENV{PERL_ONLY} :
        1;

    my $use_xs = 0;
    $try_xs and eval {
        require HTTP::XSCookies;
        $use_xs++;
    };
    if ( $use_xs ) {
        *to_header = \&xs_to_header;
    }
    else {
        *to_header = \&pp_to_header;
    }
    *_USE_XS = $use_xs ? sub () { !!1 } : sub () { !!0 };
}

sub xs_to_header {
    my $self = shift;

    # HTTP::XSCookies can't handle multi-value cookies.
    return $self->pp_to_header(@_) if @{[ $self->value ]} > 1;

    return HTTP::XSCookies::bake_cookie(
        $self->name,
        {   value    => $self->value,
            path     => $self->path,
            domain   => $self->domain,
            expires  => $self->expires,
            httponly => $self->http_only,
            secure   => $self->secure,
            samesite => $self->same_site,
        }
    );
}

sub pp_to_header {
    my $self   = shift;

    my $value = join( '&', map uri_escape($_), $self->value );
    my $no_httponly = defined( $self->http_only ) && $self->http_only == 0;

    my @headers = $self->name . '=' . $value;
    push @headers, "Path=" . $self->path          if $self->path;
    push @headers, "Expires=" . $self->expires    if $self->expires;
    push @headers, "Domain=" . $self->domain      if $self->domain;
    push @headers, "SameSite=" . $self->same_site if $self->same_site;
    push @headers, "Secure"                       if $self->secure;
    push @headers, 'HttpOnly' unless $no_httponly;

    return join '; ', @headers;
}

has value => (
    is       => 'rw',
    isa      => ArrayRef,
    required => 0,
    coerce   => sub {
        my $value = shift;
        my @values =
            is_arrayref($value) ? @$value
          : is_hashref($value)  ? %$value
          :                       ($value);
        return [@values];
    },
);

around value => sub {
    my $orig  = shift;
    my $self  = shift;
    my $array = $orig->( $self, @_ );
    return wantarray ? @$array : $array->[0];
};

sub values {
    my $self  = shift;
    return @{ $self->{'value'} || [] };
}

# this is only for overloading; need a real sub to refer to, as the Moose
# attribute accessor won't be available at that point.
sub _get_value { shift->value }

has name => (
    is       => 'rw',
    isa      => Str,
    required => 1,
);

has expires => (
    is       => 'rw',
    isa      => Str,
    required => 0,
    coerce   => sub {
        Dancer2::Core::Time->new( expression => $_[0] )->gmt_string;
    },
);

has domain => (
    is       => 'rw',
    isa      => Str,
    required => 0,
);

has path => (
    is        => 'rw',
    isa       => Str,
    default   => sub {'/'},
    predicate => 1,
);

has secure => (
    is       => 'rw',
    isa      => Bool,
    required => 0,
    default  => sub {0},
);

has http_only => (
    is       => 'rw',
    isa      => Bool,
    required => 0,
    default  => sub {1},
);

has same_site => (
    is       => 'rw',
    isa      => Enum[qw[Strict Lax None]],
    required => 0,
);

1;

__END__