File Coverage

blib/lib/Cookie/Baker.pm

Criterion	Covered	Total	%
statement	72	76	94.7
branch	36	44	81.8
condition	8	8	100.0
subroutine	10	10	100.0
pod	1	2	50.0
total	127	140	90.7

package Cookie::Baker;

use 5.008001;
use strict;
use warnings;
use base qw/Exporter/;
use URI::Escape;

BEGIN {
    our $VERSION = "0.12";
    our @EXPORT = qw/bake_cookie crush_cookie/;
    my $use_pp = $ENV{COOKIE_BAKER_PP};
    if (!$use_pp) {
        eval {
            require Cookie::Baker::XS;
            if ( $Cookie::Baker::XS::VERSION < $VERSION ) {
                warn "Cookie::Baker::XS $VERSION is require. fallback to PP version";
                die;
            }
        };
        $use_pp = !!$@;
    }
    if ($use_pp) {
        *crush_cookie = \&pp_crush_cookie;
    }
    else {
        *crush_cookie = \&Cookie::Baker::XS::crush_cookie;
    }
}

sub bake_cookie {
    my ($name,$val) = @_;

    return '' unless defined $val;
    my %args = ref $val ? %{$val} : (value => $val);
    if ($args{partitioned}) {
        # enforce SameSite=None; and secure; on CHIPS (Cookies Having Independent Partitioned State)
        $args{samesite} = 'none';
        $args{secure} = 1;
    }
    $name = URI::Escape::uri_escape($name) if $name =~ m![^a-zA-Z\-\._~]!;
    my $cookie = "$name=" . URI::Escape::uri_escape($args{value}) . '; ';
    $cookie .= 'domain=' . $args{domain} . '; '  if $args{domain};
    $cookie .= 'path='. $args{path} . '; '       if $args{path};
    $cookie .= 'expires=' . _date($args{expires}) . '; ' if exists $args{expires} && defined $args{expires};
    $cookie .= 'max-age=' . $args{"max-age"} . '; ' if exists $args{"max-age"};
    if (exists $args{samesite} && $args{samesite} =~ m/^(?:lax|strict|none)/i) {
        $cookie .= 'SameSite=' . ucfirst(lc($args{samesite})) . '; ';
        # secure flag must be set when SameSite=None
        $args{secure} = 1 if $cookie =~ m/SameSite=None; /;
    }
    $cookie .= 'secure; '                     if $args{secure};
    $cookie .= 'HttpOnly; '                   if $args{httponly};
    $cookie .= 'Partitioned; '                if $args{partitioned};

    substr($cookie,-2,2,'');
    $cookie;
}

my @MON  = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
my @WDAY = qw( Sun Mon Tue Wed Thu Fri Sat );

my %term = (
    's' => 1,
    'm' => 60,
    'h' => 3600,
    'd' => 86400,
    'M' => 86400 * 30,
    'y' => 86400 * 365,
);

sub _date {
    my $expires = shift;

    my $expires_at;
    if ($expires =~ /^\d+$/) {
        # all numbers -> epoch date
        $expires_at = $expires;
    }
    elsif ( $expires =~ /^([-+]?(?:\d+|\d*\.\d*))([smhdMy]?)/ ) {
        no warnings;
        my $offset = ($term{$2} || 1) * $1;
        $expires_at = time + $offset;
    }
    elsif ( $expires  eq 'now' ) {
        $expires_at = time;
    }
    else {
        return $expires;
    }
    my($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($expires_at);
    $year += 1900;
    # (cookies use '-' as date separator, HTTP uses ' ')
    return sprintf("%s, %02d-%s-%04d %02d:%02d:%02d GMT",
                   $WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec);
}

sub pp_crush_cookie {
    my $cookie_string = shift;
    return {} unless $cookie_string;
    my %results;
    my @pairs = grep m/=/, split /; ?/, $cookie_string;
    for my $pair ( @pairs ) {
        # trim leading trailing whitespace
        $pair =~ s/^\s+//; $pair =~ s/\s+$//;

        my ($key, $value) = split( "=", $pair, 2 );

        $key = URI::Escape::uri_unescape($key);

        # Values can be quoted
        $value = "" unless defined $value;
        $value =~ s/\A"(.*)"\z/$1/;
        $value = URI::Escape::uri_unescape($value);

        # Take the first one like CGI.pm or rack do
        $results{$key} = $value unless exists $results{$key};
    }
    return \%results;
}

1;
__END__