File Coverage

blib/lib/Dancer/Cookie.pm

Criterion	Covered	Total	%
statement	66	69	95.6
branch	36	40	90.0
condition	3	3	100.0
subroutine	10	10	100.0
pod	3	3	100.0
total	118	125	94.4

package Dancer::Cookie;
our $AUTHORITY = 'cpan:SUKRIA';
#ABSTRACT: class representing cookies
$Dancer::Cookie::VERSION = '1.3514_04'; # TRIAL
$Dancer::Cookie::VERSION = '1.351404';
use strict;
use warnings;

use Carp;
use URI::Escape;

use base 'Dancer::Object';
__PACKAGE__->attributes( qw/name expires domain path same_site secure http_only/ );

sub init {
    my ($self, %args) = @_;
    $self->value($args{value});
    if (my $time = $self->expires) {
        # First, normalize things like +2h to # of seconds
        $time = _parse_duration($time) if $time !~ /^\d+$/;

        # Then translate to a gmt string, if it isn't one already
        $time = _epoch_to_gmtstring($time) if $time =~ /^\d+$/;

        $self->expires($time);
    }
    $self->path('/') unless defined $self->path;

    # If we have a same_site attribute, ensure it's sane:
    if (my $same_site = $self->same_site) {
        if ($same_site !~ m{^(Strict|Lax|None)$}i) {
            Carp::croak(
                "Invalid same_site value '$same_site'"
                . " - must be 'Strict', 'Lax' or 'None', see RFC6265bis"
            );
        } else {
            # Normalise case
            $self->same_site(ucfirst lc $same_site);
        }
    }
}

sub to_header {
    my $self   = shift;
    my $header = '';

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

    my $name = $self->name;
    $name =~ s/[=,; \t\r\n\013\014]//mg;

    my @headers = $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, "Secure"                       if $self->secure;
    push @headers, "SameSite=" . $self->same_site if $self->same_site;
    push @headers, 'HttpOnly'                   unless $no_httponly;

    return join '; ', @headers;
}

sub value {
    my ( $self, $value ) = @_;
    if ( defined $value ) {
        my @values =
            ref $value eq 'ARRAY' ? @$value
          : ref $value eq 'HASH'  ? %$value
          :                         ($value);
        $self->{'value'} = [@values];
    }
    return wantarray ? @{ $self->{'value'} } : $self->{'value'}->[0];
}

sub _epoch_to_gmtstring {
    my ($epoch) = @_;

    my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($epoch);
    my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
    my @days   = qw(Sun Mon Tue Wed Thu Fri Sat);

    return sprintf "%s, %02d-%s-%d %02d:%02d:%02d GMT",
      $days[$wday],
      $mday,
      $months[$mon],
      ($year + 1900),
      $hour, $min, $sec;
}

# This map is taken from Cache and Cache::Cache
# map of expiration formats to their respective time in seconds
my %Units = ( map(($_,             1), qw(s second seconds sec secs)),
              map(($_,            60), qw(m minute minutes min mins)),
              map(($_,         60*60), qw(h hr hour hours)),
              map(($_,      60*60*24), qw(d day days)),
              map(($_,    60*60*24*7), qw(w week weeks)),
              map(($_,   60*60*24*30), qw(M month months)),
              map(($_,  60*60*24*365), qw(y year years)) );

# This code is taken from Time::Duration::Parse, except if it isn't
# understood it just passes it through and it adds the current time.
sub _parse_duration {
    my $timespec = shift;
    my $orig_timespec = $timespec;

    # Treat a plain number as a number of seconds (and parse it later)
    if ($timespec =~ /^\s*([-+]?\d+(?:[.,]\d+)?)\s*$/) {
        $timespec = "$1s";
    }

    # Convert hh:mm(:ss)? to something we understand
    $timespec =~ s/\b(\d+):(\d\d):(\d\d)\b/$1h $2m $3s/g;
    $timespec =~ s/\b(\d+):(\d\d)\b/$1h $2m/g;

    my $duration = 0;
    while ($timespec =~ s/^\s*([-+]?\d+(?:[.,]\d+)?)\s*([a-zA-Z]+)(?:\s*(?:,|and)\s*)*//i) {
        my($amount, $unit) = ($1, $2);
        $unit = lc($unit) unless length($unit) == 1;

        if (my $value = $Units{$unit}) {
            $amount =~ s/,/./;
            $duration += $amount * $value;
        } else {
            return $orig_timespec;
        }
    }

    if ($timespec =~ /\S/) {
        return $orig_timespec;
    }

    return sprintf "%.0f", $duration + time;
}


1;

__END__