File Coverage

blib/lib/Test2/Tools/ClassicCompare.pm

Criterion	Covered	Total	%
statement	164	179	91.6
branch	36	52	69.2
condition	4	12	33.3
subroutine	36	36	100.0
pod	6	10	60.0
total	246	289	85.1

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

our $VERSION = '0.000156';

our @EXPORT = qw/is is_deeply isnt like unlike cmp_ok/;
use base 'Exporter';

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

use Test2::API qw/context/;
use Test2::Compare qw/compare strict_convert/;
use Test2::Util::Ref qw/rtype render_ref/;
use Test2::Util::Table qw/table/;

use Test2::Compare::Array();
use Test2::Compare::Bag();
use Test2::Compare::Custom();
use Test2::Compare::Event();
use Test2::Compare::Hash();
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::Regex();
use Test2::Compare::Scalar();
use Test2::Compare::Set();
use Test2::Compare::String();
use Test2::Compare::Undef();
use Test2::Compare::Wildcard();

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

    my @caller = caller;

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

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

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

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

    my @caller = caller;

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

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

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

sub is_convert {
    my ($thing) = @_;
    return Test2::Compare::Undef->new()
        unless defined $thing;
    return Test2::Compare::String->new(input => $thing);
}

sub isnt_convert {
    my ($thing) = @_;
    return Test2::Compare::Undef->new()
        unless defined $thing;
    my $str = Test2::Compare::String->new(input => $thing, negate => 1);
}

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

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

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

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

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

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

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

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

sub like_convert {
    my ($thing) = @_;
    return Test2::Compare::Pattern->new(
        pattern       => $thing,
        stringify_got => 1,
    );
}

sub unlike_convert {
    my ($thing) = @_;
    return Test2::Compare::Pattern->new(
        negate        => 1,
        stringify_got => 1,
        pattern       => $thing,
    );
}

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

    my @caller = caller;

    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 exising behavior is to default to etc() when inside is_deeply().",
                "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);
        }
    }
    else {
        $ctx->ok(1, $name);
    }

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

our %OPS = (
    '=='  => 'num',
    '!='  => 'num',
    '>='  => 'num',
    '<='  => 'num',
    '>'   => 'num',
    '<'   => 'num',
    '<=>' => 'num',

    'eq'  => 'str',
    'ne'  => 'str',
    'gt'  => 'str',
    'lt'  => 'str',
    'ge'  => 'str',
    'le'  => 'str',
    'cmp' => 'str',
    '!~'  => 'str',
    '=~'  => 'str',

    '&&'  => 'logic',
    '||'  => 'logic',
    'xor' => 'logic',
    'or'  => 'logic',
    'and' => 'logic',
    '//'  => 'logic',

    '&' => 'bitwise',
    '|' => 'bitwise',

    '~~' => 'match',
);
sub cmp_ok($$$;$@) {
    my ($got, $op, $exp, $name, @diag) = @_;

    my $ctx = context();

    # Warnings and syntax errors should report to the cmp_ok call, not the test
    # context. They may not be the same.
    my ($pkg, $file, $line) = caller;

    my $type = $OPS{$op};
    if (!$type) {
        carp "operator '$op' is not supported (you can add it to %Test2::Tools::ClassicCompare::OPS)";
        $type = 'unsupported';
    }

    local ($@, $!, $SIG{__DIE__});

    my $test;
    my $lived = eval <<"    EOT";
#line $line "(eval in cmp_ok) $file"
\$test = (\$got $op \$exp);
1;
    EOT
    my $error = $@;
    $ctx->send_event('Exception', error => $error) unless $lived;

    if ($test && $lived) {
        $ctx->ok(1, $name);
        $ctx->release;
        return 1;
    }

    # Ugh, it failed. Do roughly the same thing Test::More did to try and show
    # diagnostics, but make it better by showing both the overloaded and
    # unoverloaded form if overloading is in play. Also unoverload numbers,
    # Test::More only unoverloaded strings.

    my ($display_got, $display_exp);
    if($type eq 'str') {
        $display_got = defined($got) ? "$got" : undef;
        $display_exp = defined($exp) ? "$exp" : undef;
    }
    elsif($type eq 'num') {
        $display_got = defined($got) ? $got + 0 : undef;
        $display_exp = defined($exp) ? $exp + 0 : undef;
    }
    else { # Well, we did what we could.
        $display_got = $got;
        $display_exp = $exp;
    }

    my $got_ref = ref($got) ? render_ref($got) : $got;
    my $exp_ref = ref($exp) ? render_ref($exp) : $exp;

    my @table;
    my $show_both = (
        (defined($got) && $got_ref ne "$display_got")
        ||
        (defined($exp) && $exp_ref ne "$display_exp")
    );

    if ($show_both) {
        @table = table(
            header => ['TYPE', 'GOT', 'OP', 'CHECK'],
            rows   => [
                [$type, $display_got, $op, $lived ? $display_exp : ''],
                ['orig', $got_ref, '', $exp_ref],
            ],
        );
    }
    else {
        @table = table(
            header => ['GOT', 'OP', 'CHECK'],
            rows   => [[$display_got, $op, $lived ? $display_exp : '']],
        );
    }

    $ctx->ok(0, $name, [join("\n", @table), @diag]);
    $ctx->release;
    return 0;
}


1;

__END__