File Coverage

blib/lib/Test/Mini/Assertions.pm

Criterion	Covered	Total	%
statement	244	247	98.7
branch	72	82	87.8
condition	54	74	72.9
subroutine	49	50	98.0
pod	25	34	73.5
total	444	487	91.1

#
# First we define some cuckoo packages that we're going to use
#
package Test::Mini::Exception;
use parent -norequire, 'Exception::Class::Base';

package Test::Mini::Exception::Assert;
use parent -norequire, 'Test::Mini::Exception';

package Test::Mini::Exception::Skip;
use parent -norequire, 'Test::Mini::Exception::Assert';

#
# And then we have the module proper itself
#
# Basic Assertions for Test::Mini.
#
package Test::Mini::Assertions;
use 5.006;
use strict;
use warnings;

use Scalar::Util      qw/ looks_like_number refaddr reftype /;
use List::Util        qw/ min any /;
use Data::Inspect;

# Formats error messages,
# appending periods and defaulting undefs as appropriate.
sub message {
    my ($default, $msg) = @_;

    $msg .= $msg ? ".\n" : '';
    $msg .= "$default.";

    return sub { return $msg };
}

# Dereferences the given argument, if possible.
sub deref {
    my ($ref) = @_;
    return %$ref if reftype($ref) eq 'HASH';
    return @$ref if reftype($ref) eq 'ARRAY';
    return $$ref if reftype($ref) eq 'SCALAR';
    return $$ref if reftype($ref) eq 'REF';
    return refaddr($ref);
}

# Produce a more useful string representation of the given argument.
sub inspect {
    Data::Inspect->new()->inspect(@_);
}

my $assertion_count = 0;

use namespace::clean;

# Pulls all of the test-related methods into the calling package.
sub import {
    my ($class) = @_;
    my $caller = caller;

    no strict 'refs';
    *{"$caller\::count_assertions"} = \&_count_assertions;
    *{"$caller\::reset_assertions"} = \&_reset_assertions;

    my @asserts = grep { /^(assert|refute|skip$|flunk$)/ && defined &{$_} } keys %{"$class\::"};

    for my $assertion (@asserts) {
        *{"$caller\::$assertion"} = \&{$assertion};
    }
}

sub _count_assertions { return $assertion_count }
sub _reset_assertions {
    my $final_count = $assertion_count;
    $assertion_count = 0;
    return $final_count;
}

# ========================
# Exported Functions
# ========================

# Assert that $test is truthy, and throw a Test::Mini::Exception::Assert
# if that assertion fails.
sub assert ($;$) {
    my ($test, $msg) = @_;
    $msg ||= 'Assertion failed; no message given.';
    $msg = $msg->() if ref $msg eq 'CODE';

    $assertion_count++;

    return 1 if $test;

    Test::Mini::Exception::Assert->throw(
        message        => $msg,
        ignore_package => [__PACKAGE__],
    );
}

# Asserts that $test is falsey, and throw a Test::Mini::Exception::Assert
# if that assertion fails.
sub refute ($;$) {
    my ($test, $msg) = @_;
    $msg ||= 'Refutation failed; no message given.';
    return assert(!$test, $msg);
}

# Asserts that the given code reference returns a truthy value.
# DEPRECATED - this will be removed in v2.0.0.
sub assert_block (&;$) {
    my ($block, $msg) = @_;
    warn '#assert_block is deprecated; please use #assert instead.';
    ($msg, $block) = ($block, $msg) if $msg && ref $block ne 'CODE';
    $msg = message('Expected block to return true value', $msg);
    assert_instance_of($block, 'CODE');
    assert($block->(), $msg);
}

# Asserts that the given code reference returns a falsey value.
# DEPRECATED - this will be removed in v2.0.0.
sub refute_block (&;$) {
    my ($block, $msg) = @_;
    warn '#refute_block is deprecated; please use #refute instead.';
    ($msg, $block) = ($block, $msg) if $msg && ref $block ne 'CODE';
    $msg = message('Expected block to return false value', $msg);
    assert_instance_of($block, 'CODE');
    refute($block->(), $msg);
}

# Verifies that the given $obj is capable of responding to the given
# $method name.
sub assert_can ($$;$) {
    my ($obj, $method, $msg) = @_;
    $msg = message("Expected @{[inspect($obj)]} (@{[ref $obj || 'SCALAR']}) to respond to #$method", $msg);
    assert($obj->can($method), $msg);
}

# Verifies that the given $obj is *not* capable of responding to the given
# $method name.
sub refute_can ($$;$) {
    my ($obj, $method, $msg) = @_;
    $msg = message("Expected @{[inspect($obj)]} (@{[ref $obj || 'SCALAR']}) to not respond to #$method", $msg);
    refute($obj->can($method), $msg);
}

# Verifies that the given $collection contains the given $obj as a member.
sub assert_contains ($$;$) {
    my ($collection, $obj, $msg) = @_;
    my $m = message("Expected @{[inspect($collection)]} to contain @{[inspect($obj)]}", $msg);
    if (ref $collection eq 'ARRAY') {
        my $search = any {defined $obj ? $_ eq $obj : defined $_ } @$collection;
        assert($search, $m);
    }
    elsif (ref $collection eq 'HASH') {
        &assert_contains([%$collection], $obj, $msg);
    }
    elsif (ref $collection) {
        assert_can($collection, 'contains');
        assert($collection->contains($obj), $m);
    }
    else {
        assert(index($collection, $obj) != -1, $m);
    }
}

# Verifies that the given $collection does not contain the given $obj as a
# member.
sub refute_contains ($$;$) {
    my ($collection, $obj, $msg) = @_;
    my $m = message("Expected @{[inspect($collection)]} to not contain @{[inspect($obj)]}", $msg);
    if (ref $collection eq 'ARRAY') {
        my $search = any {defined $obj ? $_ eq $obj : defined $_ } @$collection;
        refute($search, $m);
    }
    elsif (ref $collection eq 'HASH') {
        &refute_contains([%$collection], $obj, $msg);
    }
    elsif (ref $collection) {
        assert_can($collection, 'contains');
        refute($collection->contains($obj), $m);
    }
    else {
        refute(index($collection, $obj) != -1, $m);
    }
}

# Validates that the given $obj is defined.
sub assert_defined ($;$) {
    my ($obj, $msg) = @_;
    $msg = message("Expected @{[inspect($obj)]} to be defined", $msg);
    assert(defined $obj, $msg);
}

# Validates that the given $obj is not defined.
sub refute_defined ($;$) { goto &assert_undef }

# Tests that the supplied code block dies, and fails if it succeeds.  If
# $error is provided, the error message in $@ must contain it.
sub assert_dies (&;$$) {
    my ($sub, $error, $msg) = @_;
    $error = '' unless defined $error;

    $msg = message("Expected @{[inspect($sub)]} to die matching /$error/", $msg);
    my ($full_error, $dies);
    {
        local $@;
        $dies = not eval { $sub->(); return 1; };
        $full_error = $@;
    }
    assert($dies, $msg);
    assert_contains("$full_error", $error);
}

# Verifies the emptiness of a collection.
sub assert_empty ($;$) {
    my ($collection, $msg) = @_;
    $msg = message("Expected @{[inspect($collection)]} to be empty", $msg);
    if (ref $collection eq 'ARRAY') {
        refute(@$collection, $msg);
    }
    elsif (ref $collection eq 'HASH') {
        refute(keys %$collection, $msg);
    }
    elsif (ref $collection) {
        assert_can($collection, 'is_empty');
        assert($collection->is_empty(), $msg);
    }
    else {
        refute(length $collection, $msg);
    }
}

# Verifies the non-emptiness of a collection.
sub refute_empty ($;$) {
    my ($collection, $msg) = @_;
    $msg = message("Expected @{[inspect($collection)]} to not be empty", $msg);
    if (ref $collection eq 'ARRAY') {
        assert(@$collection, $msg);
    }
    elsif (ref $collection eq 'HASH') {
        assert(keys %$collection, $msg);
    }
    elsif (ref $collection) {
        assert_can($collection, 'is_empty');
        refute($collection->is_empty(), $msg);
    }
    else {
        assert(length $collection, $msg);
    }
}

# Checks two given arguments for equality.
sub assert_eq { goto &assert_equal }

# Checks two given arguments for inequality.
sub refute_eq { goto &refute_equal }

# Checks two given arguments for equality.
sub assert_equal ($$;$) {
    my ($actual, $expected, $msg) = @_;
    $msg = message("Got @{[inspect($actual)]}\nnot @{[inspect($expected)]}", $msg);

    my @expected = ($expected);
    my @actual   = ($actual);

    my $passed = 1;

    while ($passed && (@actual || @expected)) {
        ($actual, $expected) = (shift(@actual), shift(@expected));

        next if ref $actual && ref $expected && refaddr($actual) == refaddr($expected);

        if (eval { $expected->can('equals') }) {
            $passed = $expected->equals($actual);
        }
        elsif (ref $actual eq 'ARRAY' && ref $expected eq 'ARRAY') {
            $passed = (@$actual == @$expected);
            unshift @actual, @$actual;
            unshift @expected, @$expected;
        }
        elsif (ref $actual eq 'HASH' && ref $expected eq 'HASH') {
            $passed = (keys %$actual == keys %$expected);
            unshift @actual,   map {$_, $actual->{$_}  } sort keys %$actual;
            unshift @expected, map {$_, $expected->{$_}} sort keys %$expected;
        }
        elsif (ref $actual && ref $expected) {
            $passed = (ref $actual eq ref $expected);
            unshift @actual,   [ deref($actual)   ];
            unshift @expected, [ deref($expected) ];
        }
        elsif (looks_like_number($actual) && looks_like_number($expected)) {
            $passed = ($actual == $expected);
        }
        elsif (defined $actual && defined $expected) {
            $passed = ($actual eq $expected);
        }
        else {
            $passed = !(defined $actual || defined $expected);
        }
    }

    assert($passed, $msg);
}

# Checks two given arguments for inequality.
sub refute_equal ($$;$) {
    my ($actual, $unexpected, $msg) = @_;
    $msg = message("The given values were unexpectedly equal", $msg);

    my @unexpected = ($unexpected);
    my @actual   = ($actual);

    my $passed = 1;

    while ($passed && (@actual || @unexpected)) {
        ($actual, $unexpected) = (shift(@actual), shift(@unexpected));

        next if ref $actual && ref $unexpected && refaddr($actual) == refaddr($unexpected);

        if (eval { $unexpected->can('equals') }) {
            $passed = $unexpected->equals($actual);
        }
        elsif (ref $actual eq 'ARRAY' && ref $unexpected eq 'ARRAY') {
            $passed = (@$actual == @$unexpected);
            unshift @actual, @$actual;
            unshift @unexpected, @$unexpected;
        }
        elsif (ref $actual eq 'HASH' && ref $unexpected eq 'HASH') {
            $passed = (keys %$actual == keys %$unexpected);
            unshift @actual,     map {$_, $actual->{$_}} sort keys %$actual;
            unshift @unexpected, map {$_, $unexpected->{$_}} sort keys %$unexpected;
        }
        elsif (ref $actual && ref $unexpected) {
            $passed = (ref $actual eq ref $unexpected);
            unshift @actual,     [ deref($actual)   ];
            unshift @unexpected, [ deref($unexpected) ];
        }
        elsif (looks_like_number($actual) && looks_like_number($unexpected)) {
            $passed = ($actual == $unexpected);
        }
        elsif (defined $actual && defined $unexpected) {
            $passed = ($actual eq $unexpected);
        }
        else {
            $passed = !(defined $actual || defined $unexpected);
        }
    }

    refute($passed, $msg);
}

# Checks that the difference between $actual and $expected is less than
# $delta.
sub assert_in_delta ($$;$$) {
    my ($actual, $expected, $delta, $msg) = @_;
    $delta = 0.001 unless defined $delta;
    my $n = abs($actual - $expected);
    $msg = message("Expected $actual - $expected ($n) to be < $delta", $msg);
    assert($delta >= $n, $msg);
}

# Checks that the difference between $actual and $expected is greater than
# $delta.
sub refute_in_delta ($$;$$) {
    my ($actual, $expected, $delta, $msg) = @_;
    $delta = 0.001 unless defined $delta;
    my $n = abs($actual - $expected);
    $msg = message("Expected $actual - $expected ($n) to be > $delta", $msg);
    refute($delta >= $n, $msg);
}

# Checks that the difference between $actual and $expected is less than
# a given fraction of the smaller of the two numbers.
sub assert_in_epsilon ($$;$$) {
    my ($actual, $expected, $epsilon, $msg) = @_;
    $epsilon = 0.001 unless defined $epsilon;
    assert_in_delta(
        $actual,
        $expected,
        min(abs($actual), abs($expected)) * $epsilon,
        $msg,
    );
}

# Checks that the difference between $actual and $expected is greater than
# a given fraction of the smaller of the two numbers.
sub refute_in_epsilon ($$;$$) {
    my ($actual, $expected, $epsilon, $msg) = @_;
    $epsilon = 0.001 unless defined $epsilon;
    refute_in_delta(
        $actual,
        $expected,
        min(abs($actual), abs($expected)) * $epsilon,
        $msg,
    );
}

# Verifies that the given $collection contains the given $obj as a member.
sub assert_includes ($$;$) { goto &assert_contains }

# Verifies that the given $collection does not contain the given $obj as a
# member.
sub refute_includes ($$;$) { goto &refute_contains }

# Validates that the given object is an instance of $type.
sub assert_instance_of ($$;$) {
    my ($obj, $type, $msg) = @_;
    $msg = message("Expected @{[inspect($obj)]} to be an instance of $type, not @{[ref $obj]}", $msg);
    assert(ref $obj eq $type, $msg);
}

# Validates that $obj inherits from $type.
sub assert_is_a($$;$) {
    my ($obj, $type, $msg) = @_;
    $msg = message("Expected @{[inspect($obj)]} to inherit from $type", $msg);
    assert($obj->isa($type), $msg);
}

# Validates that $obj inherits from $type.
sub assert_isa { goto &assert_is_a }

# Validates that the given $string matches the given $pattern.
sub assert_match ($$;$) {
    my ($string, $pattern, $msg) = @_;
    $msg = message("Expected qr/$pattern/ to match against @{[inspect($string)]}", $msg);
    assert($string =~ $pattern, $msg);
}

# Validates that the given $string does not match the given $pattern.
sub refute_match ($$;$) {
    my ($string, $pattern, $msg) = @_;
    $msg = message("Expected qr/$pattern/ to fail to match against @{[inspect($string)]}", $msg);
    refute($string =~ $pattern, $msg);
}

# Verifies that the given $obj is capable of responding to the given
# $method name.
sub assert_responds_to ($$;$) { goto &assert_can }

# Verifies that the given $obj is *not* capable of responding to the given
# $method name.
sub refute_responds_to ($$;$) { goto &refute_can }

# Validates that the given $obj is undefined.
sub assert_undef ($;$) {
    my ($obj, $msg) = @_;
    $msg = message("Expected @{[inspect($obj)]} to be undefined", $msg);
    refute(defined $obj, $msg);
}

# Validates that the given $obj is not undefined.
sub refute_undef ($;$) { goto &assert_defined }

# Allows the current test to be bypassed with an indeterminate status.
sub skip (;$) {
    my ($msg) = @_;
    $msg = 'Test skipped; no message given.' unless defined $msg;
    $msg = $msg->() if ref $msg eq 'CODE';
    Test::Mini::Exception::Skip->throw(
        message        => $msg,
        ignore_package => [__PACKAGE__],
    );
}

# Causes the current test to exit immediately with a failing status.
sub flunk (;$) {
    my ($msg) = @_;
    $msg = 'Epic failure' unless defined $msg;
    assert(0, $msg);
}

1;

__END__