view release on metacpan or  search on metacpan

lib/Test/Stream/Plugin/Compare.pm  view on Meta::CPAN

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 => '<DOES NOT EXIST>', 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],
    );