File Coverage

blib/lib/Test2/Tools/Compare.pm

Criterion	Covered	Total	%
statement	314	319	98.4
branch	109	128	85.1
condition	13	14	92.8
subroutine	92	93	98.9
pod	53	53	100.0
total	581	607	95.7

package Test2::Tools::Compare;
use strict;
use warnings;

our $VERSION = '0.000156';

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

use Test2::API qw/context/;
use Test2::Util::Ref qw/rtype/;
use Test2::Util qw/pkg_to_file/;

use Test2::Compare qw{
    compare
    get_build push_build pop_build build
    strict_convert relaxed_convert
};

use Test2::Compare::Array();
use Test2::Compare::Bag();
use Test2::Compare::Bool();
use Test2::Compare::Custom();
use Test2::Compare::Event();
use Test2::Compare::Float();
use Test2::Compare::Hash();
use Test2::Compare::Isa();
use Test2::Compare::Meta();
use Test2::Compare::Number();
use Test2::Compare::Object();
use Test2::Compare::OrderedSubset();
use Test2::Compare::Pattern();
use Test2::Compare::Ref();
use Test2::Compare::DeepRef();
use Test2::Compare::Regex();
use Test2::Compare::Scalar();
use Test2::Compare::Set();
use Test2::Compare::String();
use Test2::Compare::Undef();
use Test2::Compare::Wildcard();

%Carp::Internal = (
    %Carp::Internal,
    'Test2::Tools::Compare'         => 1,
    'Test2::Compare::Array'         => 1,
    'Test2::Compare::Bag'           => 1,
    'Test2::Compare::Bool'          => 1,
    'Test2::Compare::Custom'        => 1,
    'Test2::Compare::Event'         => 1,
    'Test2::Compare::Float'         => 1,
    'Test2::Compare::Hash'          => 1,
    'Test2::Compare::Isa'           => 1,
    'Test2::Compare::Meta'          => 1,
    'Test2::Compare::Number'        => 1,
    'Test2::Compare::Object'        => 1,
    'Test2::Compare::Pattern'       => 1,
    'Test2::Compare::Ref'           => 1,
    'Test2::Compare::Regex'         => 1,
    'Test2::Compare::Scalar'        => 1,
    'Test2::Compare::Set'           => 1,
    'Test2::Compare::String'        => 1,
    'Test2::Compare::Undef'         => 1,
    'Test2::Compare::Wildcard'      => 1,
    'Test2::Compare::OrderedSubset' => 1,
);

our @EXPORT = qw/is like/;
our @EXPORT_OK = qw{
    is like isnt unlike
    match mismatch validator
    hash array bag object meta meta_check number float rounded within string subset bool check_isa
    number_lt number_le number_ge number_gt
    in_set not_in_set check_set
    item field call call_list call_hash prop check all_items all_keys all_vals all_values
    etc end filter_items
    T F D DF E DNE FDNE U L
    event fail_events
    exact_ref
};
use base 'Exporter';

my $_autodump = sub {
    my ($ctx, $got) = @_;

    my $module = $ENV{'T2_AUTO_DUMP'} or return;
    $module = 'Data::Dumper' if $module eq '1';

    my $file = pkg_to_file($module);
    eval { require $file };

    if (not $module->can('Dump')) {
        require Data::Dumper;
        $module = 'Data::Dumper';
    }

    my $deparse = $Data::Dumper::Deparse;
    $deparse = !!$ENV{'T2_AUTO_DEPARSE'} if exists $ENV{'T2_AUTO_DEPARSE'};
    local $Data::Dumper::Deparse = $deparse;

    $ctx->diag($module->Dump([$got], ['GOT']));
};

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

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

    if ($delta) {
        # Temporary thing.
        my $count = 0;
        my $implicit = 0;
        my @deltas = ($delta);
        while (my $d = shift @deltas) {
            my $add = $d->children;
            push @deltas => @$add if $add && @$add;
            next if $d->verified;
            $count++;
            $implicit++ if $d->note && $d->note eq 'implicit end';
        }

        if ($implicit == $count) {
            $ctx->ok(1, $name);
            my $meth = $ENV{AUTHOR_TESTING} ? 'throw' : 'alert';
            my $type = $delta->render_check;
            $ctx->$meth(
                join "\n",
                "!!! NOTICE OF BEHAVIOR CHANGE !!!",
                "This test uses at least 1 $type check without using end() or etc().",
                "The old behavior was to default to etc() when inside is().",
                "The old behavior was a bug.",
                "The new behavior is to default to end().",
                "This test will soon start to fail with the following diagnostics:",
                $delta->diag->as_string,
                "",
            );
        }
        else {
            $ctx->fail($name, $delta->diag, @diag);
            $ctx->$_autodump($got);
        }
    }
    else {
        $ctx->ok(1, $name);
    }

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

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

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

    if ($delta) {
        $ctx->ok(1, $name);
    }
    else {
        $ctx->ok(0, $name, ["Comparison matched (it should not).", @diag]);
        $ctx->$_autodump($got);
    }

    $ctx->release;
    return $delta ? 1 : 0;
}

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

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

    if ($delta) {
        $ctx->fail($name, $delta->diag, @diag);
        $ctx->$_autodump($got);
    }
    else {
        $ctx->ok(1, $name);
    }

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

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

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

    if ($delta) {
        $ctx->ok(1, $name);
    }
    else {
        $ctx->ok(0, $name, ["Comparison matched (it should not).", @diag]);
        $ctx->$_autodump($got);
    }

    $ctx->release;
    return $delta ? 1 : 0;
}

sub meta(&)       { build('Test2::Compare::Meta',          @_) }
sub meta_check(&) { build('Test2::Compare::Meta',          @_) }
sub hash(&)       { build('Test2::Compare::Hash',          @_) }
sub array(&)      { build('Test2::Compare::Array',         @_) }
sub bag(&)        { build('Test2::Compare::Bag',           @_) }
sub object(&)     { build('Test2::Compare::Object',        @_) }
sub subset(&)     { build('Test2::Compare::OrderedSubset', @_) }

sub U() {
    my @caller = caller;
    Test2::Compare::Custom->new(
        code => sub { defined $_ ? 0 : 1 }, name => 'UNDEFINED', operator => '!DEFINED()',
        file => $caller[1],
        lines => [$caller[2]],
    );
}

sub D() {
    my @caller = caller;
    Test2::Compare::Custom->new(
        code => sub { defined $_ ? 1 : 0 }, name => 'DEFINED', operator => 'DEFINED()',
        file => $caller[1],
        lines => [$caller[2]],
    );
}

sub DF() {
    my @caller = caller;
    Test2::Compare::Custom->new(
        code => sub { defined $_ && ( ! ref $_ && ! $_ ) ? 1 : 0 }, name => 'DEFINED BUT FALSE', operator => 'DEFINED() && FALSE()',
        file => $caller[1],
        lines => [$caller[2]],
    );
}

sub DNE() {
    my @caller = caller;
    Test2::Compare::Custom->new(
        code => sub { my %p = @_; $p{exists} ? 0 : 1 }, name => '', operator => '!exists',
        file => $caller[1],
        lines => [$caller[2]],
    );
}

sub E() {
    my @caller = caller;
    Test2::Compare::Custom->new(
        code => sub { my %p = @_; $p{exists} ? 1 : 0 }, name => '', operator => '!exists',
        file => $caller[1],
        lines => [$caller[2]],
    );
}

sub F() {
    my @caller = caller;
    Test2::Compare::Custom->new(
        code => sub { my %p = @_; $p{got} ? 0 : $p{exists} }, name => 'FALSE', operator => 'FALSE()',
        file => $caller[1],
        lines => [$caller[2]],
    );
}

sub FDNE() {
    my @caller = caller;
    Test2::Compare::Custom->new(
        code => sub {
            my %p = @_;
            return 1 unless $p{exists};
            return $p{got} ? 0 : 1;
        },
        name => 'FALSE', operator => 'FALSE() || !exists',
        file => $caller[1],
        lines => [$caller[2]],
    );
}

sub T() {
    my @caller = caller;
    Test2::Compare::Custom->new(
        code => sub {
            my %p = @_;
            return 0 unless $p{exists};
            return $p{got} ? 1 : 0;
        },
        name => 'TRUE', operator => 'TRUE()',
        file => $caller[1],
        lines => [$caller[2]],
    );
}

sub L() {
    my @caller = caller;
    Test2::Compare::Custom->new(
        code => sub { defined $_ && length $_ ? 1 : 0 }, name => 'LENGTH', operator => 'DEFINED() && LENGTH()',
        file => $caller[1],
        lines => [$caller[2]],
    );
}

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

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

sub mismatch($) {
    my @caller = caller;
    return Test2::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 Test2::Compare::Custom->new(
        file     => $caller[1],
        lines    => [$caller[2]],
        code     => $code,
        name     => $cname,
        operator => $op,
    );
}

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

sub number_lt($;@) {
    my ($num, @args) = @_;
    my @caller = caller;
    return Test2::Compare::Number->new(
        file  => $caller[1],
        lines => [$caller[2]],
        input => $num,
        mode  => '<',
        @args,
    );
}

sub number_le($;@) {
    my ($num, @args) = @_;
    my @caller = caller;
    return Test2::Compare::Number->new(
        file  => $caller[1],
        lines => [$caller[2]],
        input => $num,
        mode  => '<=',
        @args,
    );
}

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

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

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

sub rounded($$) {
    my ($num, $precision) = @_;
    my @caller = caller;
    return Test2::Compare::Float->new(
        file      => $caller[1],
        lines     => [$caller[2]],
        input     => $num,
        precision => $precision,
    );
}

sub within($;$) {
    my ($num, $tolerance) = @_;
    my @caller = caller;
    return Test2::Compare::Float->new(
        file      => $caller[1],
        lines     => [$caller[2]],
        input     => $num,
        defined $tolerance ? ( tolerance => $tolerance ) : (),
    );
}

sub bool($;@) {
    my ($bool, @args) = @_;
    my @caller = caller;
    return Test2::Compare::Bool->new(
        file  => $caller[1],
        lines => [$caller[2]],
        input => $bool,
        @args,
    );
}

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

sub check_isa($;@) {
    my ($class_name, @args) = @_;
    my @caller = caller;
    return Test2::Compare::Isa->new(
        file  => $caller[1],
        lines => [$caller[2]],
        input => $class_name,
        @args,
    );
}

sub filter_items(&) {
    defined( 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 all_items {
    defined( my $build = get_build() ) or croak "No current build!";

    croak "'$build' does not support all-items"
        unless $build->can('add_for_each');

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

    $build->add_for_each(@_);
}

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

    croak "'$build' does not support all-keys"
        unless $build->can('add_for_each_key');

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

    $build->add_for_each_key(@_);
}

*all_vals = *all_values;
sub all_values {
    defined( my $build = get_build() ) or croak "No current build!";

    croak "'$build' does not support all-values"
        unless $build->can('add_for_each_val');

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

    $build->add_for_each_val(@_);
}


sub end() {
    defined( 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 etc() {
    defined( my $build = get_build() ) or croak "No current build!";

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

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

    $build->set_ending(0);
}

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

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

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

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

sub call($$)      { $_call->(@_,'scalar','call') }
sub call_list($$) { $_call->(@_,'list','call_list') }
sub call_hash($$) { $_call->(@_,'hash','call_hash') }

sub prop($$) {
    my ($name, $expect) = @_;
    defined( 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,
        Test2::Compare::Wildcard->new(
            expect => $expect,
            file   => $caller[1],
            lines  => [$caller[2]],
        ),
    );
}

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

    defined( 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 => Test2::Compare::Wildcard->new(
        expect => $expect,
        file   => $caller[1],
        lines  => [$caller[2]],
    );

    $build->add_item(@args);
}

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

    defined( 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,
        Test2::Compare::Wildcard->new(
            expect => $expect,
            file   => $caller[1],
            lines  => [$caller[2]],
        ),
    );
}

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

    defined( 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 = Test2::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('Test2::Compare::Set', $builder);
        $set->set_builder($builder);
    }
    else {
        $set = Test2::Compare::Set->new(checks => [@_]);
    }

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

sub fail_events($;$) {
    my $event = &event(@_);

    my $diag = event('Diag');

    return ($event, $diag) if defined wantarray;

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

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

    my @caller = caller;

    croak "type is required" unless $intype;

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

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

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

    return $event if defined wantarray;

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

1;

__END__