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 URI;
use Moo;
use Plack::Util;
use JSON        qw(decode_json);
use Test::More  qw();
use Plack::Test qw();
use Data::DPath qw(dpath);



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__