File Coverage

blib/lib/Test/Stream/Plugin/Compare.pm

Criterion	Covered	Total	%
statement	213	213	100.0
branch	94	94	100.0
condition	8	8	100.0
subroutine	57	57	100.0
pod	28	31	90.3
total	400	403	99.2

package Test::Stream::Plugin::Compare;
use strict;
use warnings;

use Test::Stream::Exporter qw/import default_exports exports/;
default_exports qw/is like/;
exports qw{
    match mismatch validator
    hash array object meta number string
    in_set not_in_set check_set
    item field call prop check
    end filter_items
    T F D DNE FDNE
    event
    exact_ref
};
no Test::Stream::Exporter;

use Carp qw/croak/;
use Scalar::Util qw/reftype blessed/;

use Test::Stream::Compare qw/compare get_build push_build pop_build build/;
use Test::Stream::Context qw/context/;
use Test::Stream::Util qw/rtype/;

use Test::Stream::Compare::Array();
use Test::Stream::Compare::Custom();
use Test::Stream::Compare::Event();
use Test::Stream::Compare::Hash();
use Test::Stream::Compare::Meta();
use Test::Stream::Compare::Number();
use Test::Stream::Compare::Object();
use Test::Stream::Compare::Pattern();
use Test::Stream::Compare::Ref();
use Test::Stream::Compare::Regex();
use Test::Stream::Compare::Scalar();
use Test::Stream::Compare::Set();
use Test::Stream::Compare::String();
use Test::Stream::Compare::Undef();
use Test::Stream::Compare::Value();
use Test::Stream::Compare::Wildcard();

sub is($$;$@) {
    my ($got, $exp, $name, @diag) = @_;
    my $ctx = context();

    my $delta = compare($got, $exp, \&strict_convert);

    if ($delta) {
        $ctx->ok(0, $name, [$delta->table, @diag]);
    }
    else {
        $ctx->ok(1, $name);
    }

    $ctx->release;
    return !$delta;
}

sub like($$;$@) {
    my ($got, $exp, $name, @diag) = @_;
    my $ctx = context();

    my $delta = compare($got, $exp, \&relaxed_convert);

    if ($delta) {
        $ctx->ok(0, $name, [$delta->table, @diag]);
    }
    else {
        $ctx->ok(1, $name);
    }

    $ctx->release;
    return !$delta;
}

sub meta(&)   { build('Test::Stream::Compare::Meta',   @_) }
sub hash(&)   { build('Test::Stream::Compare::Hash',   @_) }
sub array(&)  { build('Test::Stream::Compare::Array',  @_) }
sub object(&) { build('Test::Stream::Compare::Object', @_) }

my $FDNE = Test::Stream::Compare::Custom->new(code => sub { $_ ? 0 : 1 }, name => 'FALSE', operator => 'FALSE() || !exists');
my $DNE = Test::Stream::Compare::Custom->new(code => sub { my %p = @_; $p{exists} ? 0 : 1 },          name => '', operator => '!exists');
my $F   = Test::Stream::Compare::Custom->new(code => sub { my %p = @_; $p{got}    ? 0 : $p{exists} }, name => 'FALSE',            operator => 'FALSE()');
my $T = Test::Stream::Compare::Custom->new(code => sub { $_         ? 1 : 0 }, name => 'TRUE',    operator => 'TRUE()');
my $D = Test::Stream::Compare::Custom->new(code => sub { defined $_ ? 1 : 0 }, name => 'DEFINED', operator => 'DEFINED()');

sub T()    { $T }
sub F()    { $F }
sub D()    { $D }
sub DNE()  { $DNE }
sub FDNE() { $FDNE }

sub strict_convert  { convert($_[0], 1) }
sub relaxed_convert { convert($_[0], 0) }

sub exact_ref($) {
    my @caller = caller;
    return Test::Stream::Compare::Ref->new(
        file  => $caller[1],
        lines => [$caller[2]],
        input => $_[0],
    );
}

sub match($) {
    my @caller = caller;
    return Test::Stream::Compare::Pattern->new(
        file    => $caller[1],
        lines   => [$caller[2]],
        pattern => $_[0],
    );
}

sub mismatch($) {
    my @caller = caller;
    return Test::Stream::Compare::Pattern->new(
        file    => $caller[1],
        lines   => [$caller[2]],
        negate  => 1,
        pattern => $_[0],
    );
}

sub validator {
    my $code = pop;
    my $cname = pop;
    my $op = pop;

    my @caller = caller;
    return Test::Stream::Compare::Custom->new(
        file     => $caller[1],
        lines    => [$caller[2]],
        code     => $code,
        name     => $cname,
        operator => $op,
    );
}

sub number($;@) {
    my ($num, @args) = @_;
    my @caller = caller;
    return Test::Stream::Compare::Number->new(
        file  => $caller[1],
        lines => [$caller[2]],
        input => $num,
        @args,
    );
}

sub string($;@) {
    my ($str, @args) = @_;
    my @caller = caller;
    return Test::Stream::Compare::String->new(
        file  => $caller[1],
        lines => [$caller[2]],
        input => $str,
        @args,
    );
}

sub filter_items(&) {
    my $build = get_build() or croak "No current build!";

    croak "'$build' does not support filters"
        unless $build->can('add_filter');

    croak "'filter_items' should only ever be called in void context"
        if defined wantarray;

    $build->add_filter(@_);
}

sub end() {
    my $build = get_build() or croak "No current build!";

    croak "'$build' does not support 'ending'"
        unless $build->can('ending');

    croak "'end' should only ever be called in void context"
        if defined wantarray;

    $build->set_ending(1);
}

sub call($$) {
    my ($name, $expect) = @_;
    my $build = get_build() or croak "No current build!";

    croak "'$build' does not support method calls"
        unless $build->can('add_call');

    croak "'call' should only ever be called in void context"
        if defined wantarray;

    my @caller = caller;
    $build->add_call(
        $name,
        Test::Stream::Compare::Wildcard->new(
            expect => $expect,
            file   => $caller[1],
            lines  => [$caller[2]],
        ),
    );
}

sub prop($$) {
    my ($name, $expect) = @_;
    my $build = get_build() or croak "No current build!";

    croak "'$build' does not support meta-checks"
        unless $build->can('add_prop');

    croak "'prop' should only ever be called in void context"
        if defined wantarray;

    my @caller = caller;
    $build->add_prop(
        $name,
        Test::Stream::Compare::Wildcard->new(
            expect => $expect,
            file   => $caller[1],
            lines  => [$caller[2]],
        ),
    );
}

sub item($;$) {
    my @args   = @_;
    my $expect = pop @args;

    my $build = get_build() or croak "No current build!";

    croak "'$build' does not support array item checks"
        unless $build->can('add_item');

    croak "'item' should only ever be called in void context"
        if defined wantarray;

    my @caller = caller;
    push @args => Test::Stream::Compare::Wildcard->new(
        expect => $expect,
        file   => $caller[1],
        lines  => [$caller[2]],
    );

    $build->add_item(@args);
}

sub field($$) {
    my ($name, $expect) = @_;

    my $build = get_build() or croak "No current build!";

    croak "'$build' does not support hash field checks"
        unless $build->can('add_field');

    croak "'field' should only ever be called in void context"
        if defined wantarray;

    my @caller = caller;
    $build->add_field(
        $name,
        Test::Stream::Compare::Wildcard->new(
            expect => $expect,
            file   => $caller[1],
            lines  => [$caller[2]],
        ),
    );
}

sub check($) {
    my ($check) = @_;

    my $build = get_build() or croak "No current build!";

    croak "'$build' is not a check-set"
        unless $build->can('add_check');

    croak "'check' should only ever be called in void context"
        if defined wantarray;

    my @caller = caller;
    my $wc = Test::Stream::Compare::Wildcard->new(
        expect => $check,
        file   => $caller[1],
        lines  => [$caller[2]],
    );

    $build->add_check($wc);
}

sub check_set  { return _build_set('all'  => @_) }
sub in_set     { return _build_set('any'  => @_) }
sub not_in_set { return _build_set('none' => @_) }

sub _build_set {
    my $redux = shift;
    my ($builder) = @_;
    my $btype = reftype($builder) || '';

    my $set;
    if ($btype eq 'CODE') {
        $set = build('Test::Stream::Compare::Set', $builder);
        $set->set_builder($builder);
    }
    else {
        $set = Test::Stream::Compare::Set->new(checks => [@_]);
    }

    $set->set_reduction($redux);
    return $set;
}

sub event($;$) {
    my ($intype, $spec) = @_;

    my @caller = caller;

    croak "type is required" unless $intype;

    my $type;
    if ($intype =~ m/^\+(.*)$/) {
        $type = $1;
    }
    else {
        $type = "Test::Stream::Event::$intype";
    }

    my $event;
    if (!$spec) {
        $event = Test::Stream::Compare::Event->new(
            etype => $intype,
            file  => $caller[1],
            lines => [$caller[2]],
        );
    }
    elsif (!ref $spec) {
        croak "'$spec' is not a valid event specification"
    }
    elsif (reftype($spec) eq 'CODE') {
        $event = build('Test::Stream::Compare::Event', $spec);
        $event->set_etype($intype),
        $event->set_builder($spec);
    }
    else {
        my $refcheck = Test::Stream::Compare::Hash->new(
            inref => $spec,
            file  => $caller[1],
            lines => [$caller[2]],
        );
        $event = Test::Stream::Compare::Event->new(
            refcheck => $refcheck,
            file     => $caller[1],
            lines    => [$caller[2]],
            etype => $intype,
        );
    }

    $event->add_prop('blessed' => $type);

    return $event if defined wantarray;

    my $build = get_build() or croak "No current build!";
    $build->add_item($event);
}

sub convert {
    my ($thing, $strict) = @_;

    return Test::Stream::Compare::Undef->new()
        unless defined $thing;

    if ($thing && blessed($thing) && $thing->isa('Test::Stream::Compare')) {
        return $thing unless $thing->isa('Test::Stream::Compare::Wildcard');
        my $newthing = convert($thing->expect, $strict);
        $newthing->set_builder($thing->builder) unless $newthing->builder;
        $newthing->set_file($thing->_file)      unless $newthing->_file;
        $newthing->set_lines($thing->_lines)    unless $newthing->_lines;
        return $newthing;
    }

    my $type = rtype($thing);

    return Test::Stream::Compare::Array->new(inref => $thing, $strict ? (ending => 1) : ())
        if $type eq 'ARRAY';

    return Test::Stream::Compare::Hash->new(inref => $thing, $strict ? (ending => 1) : ())
        if $type eq 'HASH';

    unless ($strict) {
        return Test::Stream::Compare::Pattern->new(
            pattern       => $thing,
            stringify_got => 1,
        ) if $type eq 'REGEXP';

        return Test::Stream::Compare::Custom->new(code => $thing)
            if $type eq 'CODE';
    }

    return Test::Stream::Compare::Regex->new(input => $thing)
        if $type eq 'REGEXP';

    if ($type eq 'SCALAR') {
        my $nested = convert($$thing, $strict);
        return Test::Stream::Compare::Scalar->new(item => $nested)
    }

    return Test::Stream::Compare::Ref->new(input => $thing)
        if $type;

    # is() will assume string and use 'eq'
    return Test::Stream::Compare::String->new(input => $thing);
}

1;

__END__