File Coverage

blib/lib/Assert/Refute/T/Tester.pm

Criterion	Covered	Total	%
statement	41	41	100.0
branch	15	16	93.7
condition	9	12	75.0
subroutine	9	9	100.0
pod			n/a
total	74	78	94.8

package Assert::Refute::T::Tester;

use strict;
use warnings;
our $VERSION = '0.16';

=head1 NAME

Assert::Refute::T::Tester - test the test conditions themselves

=head1 DESCRIPTION

This module is inspired by L.
While C is a good way to quickly determine
whether a test condition holds any water, a more detailed
inspection is desirable.

B<[EXPERIMENTAL]> This module is under active development and
its interface may change in the future.

=head1 SYNOPSIS

    use Test::More;
    use Assert::Refute::T::Tester;

    use My::Refute::Module qw(check_this check_that);

    my $report = try_refute {
        check_this(...); # pass
        check_that(...); # fail
    };

    test_test
        $report->get_result_details(0),
        { diag => [] },
        "No premature output";

    test_test
        $report->get_result_details(1),
        { ok => 1 },
        "Passing test";

    test_test
        $report->get_result_details(2),
        { ok => 0, diag => [ qr/foo/, qr/bar/ ] },
        "Failing test";

=head1 EXPORT

The following functions are exported by default:

=cut

use Carp;
use parent qw(Exporter);
use Assert::Refute::Build;

=head2 test_test

    test_test \%result_details, \%spec, "Message";

Result details come from L.

The exact format MAY change in the future, but this test should keep working.

%spec may include:

=over

=item * C - whether the test passed or not.

=item * C - test name (without the number)
Can be exact string or regular expression.

=item * C - an array of exact strings or regular expressions.
Each line of output will be matched against exactly one expectation.

Output produced by C is ignored.

=back

=cut

build_refute test_test => \&_test_test, manual => 1, args => 2, export => 1;

my %allow;
$allow{$_}++ for qw( ok name diag );
sub _test_test {
    my ($self, $hash, $spec, $external_name) = @_;

    croak "Usage: test_test( \%test_result, \%spec, [ \"message\" ] )"
        if (ref $hash ne 'HASH' or ref $spec ne 'HASH');

    my @extra = grep { !$allow{$_} } keys %$spec;
    croak "test_test(): Unknown fields (@extra) in spec"
        if @extra;

    my $ok = $spec->{ok};
    my $name = $spec->{name};
    my $diag = $spec->{diag};

    croak "test_test(): diag() must be an array of strings and/or regular expressions"
        if $diag and ref $diag ne 'ARRAY';

    $external_name ||= "Assert::Refute contract entry as expected";

    $self->subcontract( $external_name => sub {
        my $rep = shift;

        if (defined $ok) {
            $rep->refute( ($ok xor $hash->{ok}), "test ".($ok?"passed":"failed"));
        };

        if (defined $name) {
            _like_or_ok( $rep, $hash->{name}, $name, "Test name is $name" );
        };

        if (defined $diag) {
            _lines_like( $rep, $hash->{diag}, $diag, "Diagnostics" );
        };
    } );
};

sub _lines_like {
    my ($rep, $got, $exp, $message) = @_;

    foreach (0 .. @$exp-1) {
        _like_or_ok( $rep, $got->[$_], $exp->[$_],
            "$message: Line $_ matches ".to_scalar( $exp->[$_] ) );
    };
    $rep->is( scalar @$got, scalar @$exp,
        "$message: Exactly ".(scalar @$exp)." lines present" );
};

sub _like_or_ok {
    my ($rep, $got, $exp, $msg) = @_;

    if (ref $exp eq 'Regexp') {
        $rep->like( $got, $exp, $msg );
    } else {
        $rep->is( $got, $exp, $msg );
    };
};

=head1 LICENSE AND COPYRIGHT

This module is part of L suite.

Copyright 2017-2018 Konstantin S. Uvarin. C<<  >>

This program is free software; you can redistribute it and/or modify it
under the terms of the the Artistic License (2.0). You may obtain a
copy of the full license at:

L

=cut

1;