File Coverage

blib/lib/Plack/Test/Simple/Transaction.pm

Criterion	Covered	Total	%
statement	51	87	58.6
branch	4	8	50.0
condition	3	41	7.3
subroutine	16	28	57.1
pod	14	14	100.0
total	88	178	49.4

# ABSTRACT: PSGI Automated Application Testing Layer
package Plack::Test::Simple::Transaction;

use utf8;

use HTTP::Request;
use HTTP::Response;
use Moo;
use Plack::Util;
use URI;

use Plack::Test qw();
use Test::More qw();

use Data::DPath qw(dpath);
use JSON qw(decode_json);

our $VERSION = '0.02'; # VERSION

has data => (
    is      => 'rw',
    lazy    => 1,
    builder => 1
);

sub _build_data {
    my ($self) = @_;

    return {} unless $self->response->content;
    return {} unless $self->response->header('Content-Type');
    return {} unless $self->response->header('Content-Type') =~ /json/i;

    # only supporting JSON data currently !!!
    return decode_json $self->response->decoded_content;
}

has psgi => (
    is   => 'rw',
);

has request => (
    is      => 'rw',
    lazy    => 1,
    builder => 1
);

sub _build_request {
    return HTTP::Request->new(
        uri => URI->new(scheme => 'http', host => 'localhost', path => '/')
    )
}

has response => (
    is      => 'rw',
    lazy    => 1,
    builder => 1
);

sub _build_response {
    my $self = shift;
    return $self->psgi->request($self->request);
}

sub content_is {
    my ($self, $value, $desc) = @_;
    $desc ||= 'exact match for content';
    return $self->_test_more(
        'is', $self->response->decoded_content, $value, $desc
    );
}

sub content_isnt {
    my ($self, $value, $desc) = @_;
    $desc ||= 'not an exact match for content';
    return $self->_test_more(
        'isnt', $self->response->decoded_content, $value, $desc
    );
}

sub content_like {
    my ($self, $regex, $desc) = @_;
    $desc ||= 'content contains the expression specified';
    return $self->_test_more(
        'like', $self->response->decoded_content, $regex, $desc
    );
}

sub content_unlike {
    my ($self, $regex, $desc) = @_;
    $desc ||= 'content does not contain the expression specified';
    return $self->_test_more(
        'unlike', $self->response->decoded_content, $regex, $desc
    );
}

sub data_has {
    my ($self, $path, $desc) = @_;
    $desc ||= qq{has value for data path "$path"};
    my $rs = [ dpath($path)->match($self->data) ];
    return $self->_test_more(
        'ok', $rs->[0], $desc
    );
}

sub data_hasnt {
    my ($self, $path, $desc) = @_;
    $desc ||= qq{has no value for data path "$path"};
    my $rs = [ dpath($path)->match($self->data) ];
    return $self->_test_more(
        'ok', !$rs->[0], $desc
    );
}

sub data_is_deeply {
    my $self = shift;
    my ($path, $data) = ref $_[0] ? ('', shift) : (shift, shift);
    $path ||= '/';
    my $desc ||= qq{exact match for data path "$path"};
    my $rs = [ dpath($path)->match($self->data) ];
    return $self->_test_more(
        'is_deeply', $rs->[0], $data, $desc
    );
}

sub data_match {
    goto &data_is_deeply;
}

sub header_is {
    my ($self, $name, $value, $desc) = @_;
    $desc ||= "exact match for header $name with value " . ($value // '');
    return $self->_test_more(
        'is', $self->response->header($name), $value, $desc
    );
}

sub header_isnt {
    my ($self, $name, $value, $desc) = @_;
    $desc ||= "not an exact match for header $name with value " . ($value // '');
    return $self->_test_more(
        'isnt', $self->response->header($name), $value, $desc
    );
}

sub header_like {
    my ($self, $name, $regex, $desc) = @_;
    $desc ||= "header $name contains the expression specified";
    return $self->_test_more(
        'like', $self->response->header($name), $regex, $desc
    );
}

sub header_unlike {
    my ($self, $name, $regex, $desc) = @_;
    $desc ||= "header $name does not contain the expression specified";
    return $self->_test_more(
        'unlike', $self->response->header($name), $regex, $desc
    );
}

sub status_is {
    my ($self, $code, $desc) = @_;
    $desc ||= "status is $code";
    return $self->_test_more(
        'is', $self->response->code, $code, $desc
    );
}

sub status_isnt {
    my ($self, $code, $desc) = @_;
    $desc ||= "status is not $code";
    return $self->_test_more(
        'isnt', $self->response->code, $code, $desc
    );
}

sub _test_more {
    my ($self, $name, @args) = @_;

    local $Test::Builder::Level = $Test::Builder::Level + 2;
    Test::More->can($name)->(@args);

    return $self;
}

1;

__END__