File Coverage

blib/lib/HTTP/CookieMonster.pm

Criterion	Covered	Total	%
statement	71	73	97.2
branch	19	24	79.1
condition			n/a
subroutine	18	18	100.0
pod	5	6	83.3
total	113	121	93.3

package HTTP::CookieMonster;
our $VERSION = '0.11';
use strict;
use warnings;

use 5.006;

use Moo 1.000003;
use Carp qw( croak );
use HTTP::Cookies;
use HTTP::CookieMonster::Cookie;
use Safe::Isa;
use Scalar::Util qw( reftype );
use Sub::Exporter -setup => { exports => ['cookies'] };
use URI::Escape qw( uri_escape uri_unescape );

my @_cookies = ();
has 'cookie_jar' => (
    required => 1,
    is       => 'ro',
    isa      => sub {
        croak 'HTTP::Cookies object expected'
            if !$_[0]->$_isa('HTTP::Cookies');
    },
);

sub BUILDARGS {
    my ( $class, @args ) = @_;

    return { cookie_jar => shift @args } if @args == 1;
    return {@args};
}

# all_cookies() is now a straight method rather than a Moo accessor in order to
# prevent the all_cookies list from getting out of sync with changes to the
# cookie_jar which happen outside of this module.  Rather than trying to detect
# changes, we'll just create a fresh list each time.  Performance penalties
# should be minimal and this keeps things simple.

sub all_cookies {
    my $self = shift;
    @_cookies = ();
    $self->cookie_jar->scan( \&_check_cookies );

    wantarray ? return @_cookies : return \@_cookies;
}

# my $cookie = cookies( $jar ); -- first cookie (makes no sense)
# my $session = cookies( $jar, 'session' );
# my @cookies = cookies( $jar );
# my @sessions = cookies( $jar, 'session' );

sub cookies {
    my ( $cookie_jar, $name ) = @_;
    croak 'This function is not part of the OO interface'
        if $cookie_jar->$_isa('HTTP::CookieMonster');

    my $monster = HTTP::CookieMonster->new($cookie_jar);

    if ( !$name ) {
        if ( !wantarray ) {
            croak
                'Please specify a cookie name when asking for a single cookie';
        }
        return @{ $monster->all_cookies };
    }

    return $monster->get_cookie($name);
}

sub get_cookie {
    my $self = shift;
    my $name = shift;

    my @cookies = ();
    foreach my $cookie ( $self->all_cookies ) {
        if ( $cookie->key eq $name ) {
            return $cookie if !wantarray;
            push @cookies, $cookie;
        }
    }

    return shift @cookies if !wantarray;
    return @cookies;
}

sub set_cookie {
    my $self   = shift;
    my $cookie = shift;

    if ( !$cookie ) {
        croak 'Missing cookie, an HTTP::CookieMonster::Cookie object';
    }

    if ( !$cookie->$_isa('HTTP::CookieMonster::Cookie') ) {
        croak "$cookie is not a HTTP::CookieMonster::Cookie object";
    }

    return $self->cookie_jar->set_cookie(
        $cookie->version,           $cookie->key,
        uri_escape( $cookie->val ), $cookie->path,
        $cookie->domain,            $cookie->port,
        $cookie->path_spec,         $cookie->secure,
        $cookie->expires,           $cookie->discard,
        $cookie->hash
    ) ? 1 : 0;
}

sub delete_cookie {
    my $self   = shift;
    my $cookie = shift;

    if ( !$cookie->$_isa('HTTP::CookieMonster::Cookie') ) {
        croak "$cookie is not a HTTP::CookieMonster::Cookie object";
    }

    $cookie->expires(-1);

    return $self->set_cookie($cookie);
}

sub _check_cookies {
    my @args = @_;

    push @_cookies,
        HTTP::CookieMonster::Cookie->new(
        version   => $args[0],
        key       => $args[1],
        val       => uri_unescape( $args[2] ),
        path      => $args[3],
        domain    => $args[4],
        port      => $args[5],
        path_spec => $args[6],
        secure    => $args[7],
        expires   => $args[8],
        discard   => $args[9],
        hash      => $args[10],
        );

    return;
}

1;

# ABSTRACT: Easy read/write access to your jar of HTTP::Cookies
#

__END__