view release on metacpan or  search on metacpan

lib/Test2/Tools/Compare.pm  view on Meta::CPAN

    %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);
    }

lib/Test2/Tools/Compare.pm  view on Meta::CPAN

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