File Coverage

blib/lib/Test2/Compare.pm

Criterion	Covered	Total	%
statement	93	94	98.9
branch	55	60	91.6
condition	24	24	100.0
subroutine	17	17	100.0
pod	8	8	100.0
total	197	203	97.0

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

our $VERSION = '0.000153';

use Scalar::Util qw/blessed/;
use Test2::Util qw/try/;
use Test2::Util::Ref qw/rtype/;

use Carp qw/croak/;

our @EXPORT_OK = qw{
    compare
    get_build push_build pop_build build
    strict_convert relaxed_convert convert
};
use base 'Exporter';

sub compare {
    my ($got, $check, $convert) = @_;

    $check = $convert->($check);

    return $check->run(
        id      => undef,
        got     => $got,
        exists  => 1,
        convert => $convert,
        seen    => {},
    );
}

my @BUILD;

sub get_build  { @BUILD ? $BUILD[-1] : undef }
sub push_build { push @BUILD => $_[0] }

sub pop_build {
    return pop @BUILD if @BUILD && $_[0] && $BUILD[-1] == $_[0];
    my $have = @BUILD ? "$BUILD[-1]" : 'undef';
    my $want = $_[0]  ? "$_[0]"      : 'undef';
    croak "INTERNAL ERROR: Attempted to pop incorrect build, have $have, tried to pop $want";
}

sub build {
    my ($class, $code) = @_;

    my @caller = caller(1);

    die "'$caller[3]\()' should not be called in void context in $caller[1] line $caller[2]\n"
        unless defined(wantarray);

    my $build = $class->new(builder => $code, called => \@caller);

    push @BUILD => $build;
    my ($ok, $err) = try { $code->($build); 1 };
    pop @BUILD;
    die $err unless $ok;

    return $build;
}

sub strict_convert  { convert($_[0], { implicit_end => 1, use_regex => 0, use_code => 0 }) }
sub relaxed_convert { convert($_[0], { implicit_end => 0, use_regex => 1, use_code => 1 }) }

my $CONVERT_LOADED = 0;
my %ALLOWED_KEYS = ( implicit_end => 1, use_regex => 1, use_code => 1 );
sub convert {
    my ($thing, $config) = @_;

    unless($CONVERT_LOADED) {
        require Test2::Compare::Array;
        require Test2::Compare::Base;
        require Test2::Compare::Custom;
        require Test2::Compare::DeepRef;
        require Test2::Compare::Hash;
        require Test2::Compare::Pattern;
        require Test2::Compare::Ref;
        require Test2::Compare::Regex;
        require Test2::Compare::Scalar;
        require Test2::Compare::String;
        require Test2::Compare::Undef;
        require Test2::Compare::Wildcard;
        $CONVERT_LOADED = 1;
    }

    if (ref($config)) {
        my $bad = join ', ' => grep { !$ALLOWED_KEYS{$_} } keys %$config;
        croak "The following config options are not understood by convert(): $bad" if $bad;
        $config->{implicit_end} = 1 unless defined $config->{implicit_end};
        $config->{use_regex}    = 1 unless defined $config->{use_regex};
        $config->{use_code}     = 0 unless defined $config->{use_code};
    }
    else { # Legacy...
        if ($config) {
            $config = {
                implicit_end => 1,
                use_regex  => 0,
                use_code   => 0,
            };
        }
        else {
            $config = {
                implicit_end => 0,
                use_regex  => 1,
                use_code   => 1,
            };
        }
    }

    return _convert($thing, $config);
}

sub _convert {
    my ($thing, $config) = @_;

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

    if (blessed($thing) && $thing->isa('Test2::Compare::Base')) {
        if ($config->{implicit_end} && $thing->can('set_ending') && !defined $thing->ending) {
            my $clone = $thing->clone;
            $clone->set_ending('implicit');
            return $clone;
        }

        return $thing unless $thing->isa('Test2::Compare::Wildcard');
        my $newthing = _convert($thing->expect, $config);
        $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 Test2::Compare::Array->new(inref => $thing, $config->{implicit_end} ? (ending => 1) : ())
        if $type eq 'ARRAY';

    return Test2::Compare::Hash->new(inref => $thing, $config->{implicit_end} ? (ending => 1) : ())
        if $type eq 'HASH';

    return Test2::Compare::Pattern->new(
        pattern       => $thing,
        stringify_got => 1,
    ) if $config->{use_regex} && $type eq 'REGEXP';

    return Test2::Compare::Custom->new(code => $thing)
        if $config->{use_code} && $type eq 'CODE';

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

    if ($type eq 'SCALAR' || $type eq 'VSTRING') {
        my $nested = _convert($$thing, $config);
        return Test2::Compare::Scalar->new(item => $nested);
    }

    return Test2::Compare::DeepRef->new(input => $thing)
        if $type eq 'REF';

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

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

1;

__END__