File Coverage

blib/lib/CGI/Simple/Cookie.pm

Criterion	Covered	Total	%
statement	121	121	100.0
branch	77	88	87.5
condition	15	23	65.2
subroutine	22	22	100.0
pod	11	17	64.7
total	246	271	90.7

package CGI::Simple::Cookie;

# Original version Copyright 1995-1999, Lincoln D. Stein. All rights reserved.
# It may be used and modified freely, but I do request that this copyright
# notice remain attached to the file.  You may modify this module as you
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.

# This version Copyright 2001, Dr James Freeman. All rights reserved.
# Renamed, strictified, and generally hacked code. Now 30% shorter.
# Interface remains identical and passes all original CGI::Cookie tests

use strict;
use warnings;
use vars '$VERSION';
$VERSION = '1.282';
use CGI::Simple::Util qw(rearrange unescape escape);
use overload '""' => \&as_string, 'cmp' => \&compare, 'fallback' => 1;

# fetch a list of cookies from the environment and return as a hash.
# the cookies are parsed as normal escaped URL data.
sub fetch {
  my $self = shift;
  my $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
  return () unless $raw_cookie;
  return $self->parse( $raw_cookie );
}

sub parse {
  my ( $self, $raw_cookie ) = @_;
  return () unless $raw_cookie;
  my %results;
  my @pairs = split "[;,] ?", $raw_cookie;
  for my $pair ( @pairs ) {
    # trim leading trailing whitespace
    $pair =~ s/^\s+//;
    $pair =~ s/\s+$//;
    my ( $key, $value ) = split( "=", $pair, 2 );
    next if !defined( $value );
    my @values = ();
    if ( $value ne '' ) {
      @values = map unescape( $_ ), split( /[&;]/, $value . '&dmy' );
      pop @values;
    }
    $key = unescape( $key );

    # A bug in Netscape can cause several cookies with same name to
    # appear.  The FIRST one in HTTP_COOKIE is the most recent version.
    $results{$key} ||= $self->new( -name => $key, -value => \@values );
  }
  return wantarray ? %results : \%results;
}

# fetch a list of cookies from the environment and return as a hash.
# the cookie values are not unescaped or altered in any way.
sub raw_fetch {
  my $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
  return () unless $raw_cookie;
  my %results;
  my @pairs = split "; ?", $raw_cookie;
  for my $pair ( @pairs ) {
    $pair =~ s/^\s+|\s+$//;    # trim leading trailing whitespace
    my ( $key, $value ) = split "=", $pair;

    # fixed bug that does not allow 0 as a cookie value thanks Jose Mico
    # $value ||= 0;
    $value = defined $value ? $value : '';
    $results{$key} = $value;
  }
  return wantarray ? %results : \%results;
}

sub new {
  my ( $class, @params ) = @_;
  $class = ref( $class ) || $class;
  my (
    $name,   $value,   $path,    $domain,
    $secure, $expires, $max_age, $httponly, $samesite,
    $priority, $partitioned
   )
   = rearrange(
    [
      'NAME', [ 'VALUE', 'VALUES' ],
      'PATH',    'DOMAIN',
      'SECURE',  'EXPIRES',
      'MAX-AGE', 'HTTPONLY', 'SAMESITE',
      'PRIORITY', 'PARTITIONED',
    ],
    @params
   );
  return undef unless defined $name and defined $value;
  my $self = {};
  bless $self, $class;
  $self->name( $name );
  $self->value( $value );
  $path ||= "/";
  $self->path( $path )               if defined $path;
  $self->domain( $domain )           if defined $domain;
  $self->secure( $secure )           if defined $secure;
  $self->expires( $expires )         if defined $expires;
  $self->max_age( $max_age )         if defined $max_age;
  $self->httponly( $httponly )       if defined $httponly;
  $self->samesite( $samesite )       if defined $samesite;
  $self->priority( $priority )       if defined $priority;
  $self->partitioned( $partitioned ) if defined $partitioned;
  return $self;
}

sub as_string {
  my $self = shift;
  return "" unless $self->name;
  my $name   = escape( $self->name );
  my $value  = join "&", map { escape( $_ ) } $self->value;
  my @cookie = ( "$name=$value" );
  push @cookie, "domain=" . $self->domain     if $self->domain;
  push @cookie, "path=" . $self->path         if $self->path;
  push @cookie, "expires=" . $self->expires   if $self->expires;
  push @cookie, "max-age=" . $self->max_age   if $self->max_age;
  push @cookie, "secure"                      if $self->secure;
  push @cookie, "HttpOnly"                    if $self->httponly;
  push @cookie, "SameSite=" . $self->samesite if $self->samesite;
  push @cookie,"Priority=".$self->priority if $self->priority;
  push @cookie,"Partitioned"               if $self->partitioned;
  return join "; ", @cookie;
}

sub compare {
  my ( $self, $value ) = @_;
  return "$self" cmp $value;
}

# accessors subs
sub name {
  my ( $self, $name ) = @_;
  $self->{'name'} = $name if defined $name;
  return $self->{'name'};
}

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 domain {
  my ( $self, $domain ) = @_;
  $self->{'domain'} = $domain if defined $domain;
  return $self->{'domain'};
}

sub secure {
  my ( $self, $secure ) = @_;
  $self->{'secure'} = $secure if defined $secure;
  return $self->{'secure'};
}

sub expires {
  my ( $self, $expires ) = @_;
  $self->{'expires'} = CGI::Simple::Util::expires( $expires, 'cookie' )
   if defined $expires;
  return $self->{'expires'};
}

sub max_age {
  my ( $self, $max_age ) = @_;
  $self->{'max-age'}
   = CGI::Simple::Util::_expire_calc( $max_age ) - time()
   if defined $max_age;
  return $self->{'max-age'};
}

sub path {
  my ( $self, $path ) = @_;
  $self->{'path'} = $path if defined $path;
  return $self->{'path'};
}

sub httponly {
  my ( $self, $httponly ) = @_;
  $self->{'httponly'} = $httponly if defined $httponly;
  return $self->{'httponly'};
}

sub partitioned { # Partitioned
    my ( $self, $partitioned ) = @_;
    $self->{'partitioned'} = $partitioned if defined $partitioned;
    return $self->{'partitioned'};
}

my %_legal_samesite = ( Strict => 1, Lax => 1, None => 1 );
sub samesite {
    my $self = shift;
    my $samesite = ucfirst lc +shift if @_; # Normalize casing.
    $self->{'samesite'} = $samesite if $samesite and $_legal_samesite{$samesite};
    return $self->{'samesite'};
}

my %_legal_priority = ( Low => 1, Medium => 1, High => 1 );
sub priority {
    my $self = shift;
    my $priority = ucfirst lc +shift if @_;
    if ($priority && $_legal_priority{$priority}) {
        $self->{'priority'} = $priority;
    }
    return $self->{'priority'};
}

1;

__END__