File Coverage

blib/lib/Test/Run/Trap/Obj.pm

Criterion	Covered	Total	%
statement	50	64	78.1
branch	4	12	33.3
condition	4	7	57.1
subroutine	14	16	87.5
pod	6	6	100.0
total	78	105	74.2

package Test::Run::Trap::Obj;

use strict;
use warnings;

=head1 NAME

Test::Run::Trap::Obj - wrapper around Test::Trap for trapping errors.

=head1 SYNPOSIS

    my $got = Test::Run::Trap::Obj->trap_run({
        args => [test_files => ["t/sample-tests/simple"]]
    });

    $got->field_like("stdout", qr/All tests successful/,
        "Everything is OK."
    );

=head1 DESCRIPTION

This class implements a wrapper around L<Test::Trap>. When an
assertion files, the diagnostics prints all the relevant and trapped
fields for easy debugging.

=head1 METHODS

=cut

use Moose;

extends('Test::Run::Base::Struct');


use Test::More;
use Data::Dumper ();

use Text::Sprintf::Named;

use Test::Trap qw( trap $trap :flow:stderr(systemsafe):stdout(systemsafe):warn );

use Test::Run::Obj;

my @fields = qw(
    die
    exit
    leaveby
    return
    stderr
    stdout
    wantarray
    warn
    run_func
);


has 'die' => (is => "rw", isa => "Any");
has 'exit' => (is => "rw", isa => "Any");
has 'leaveby' => (is => "rw", isa => "Str");
has 'return' => (is => "rw", isa => "Any");
has 'stderr' => (is => "rw", isa => "Str");
has 'stdout' => (is => "rw", isa => "Str");
has 'wantarray' => (is => "rw", isa => "Bool");
has 'warn' => (is => "rw", isa => "Any");
has 'run_func' => (is => "rw", isa => "CodeRef");

sub _stringify_value
{
    my ($self, $name) = @_;

    my $value = $self->$name();

    if (($name eq "return") || ($name eq "warn"))
    {
        return Data::Dumper->new([$value])->Dump();
    }
    else
    {
        return (defined($value) ? $value : "");
    }
}

=head2 $trapper->diag_all()

Calls L<Test::More>'s diag() with all the trapped fields, like stdout,
stderr, etc.

=cut

sub diag_all
{
    my $self = shift;

    diag(
        Text::Sprintf::Named->new(
            {
                fmt =>
            join( "",
            map { "$_ ===\n{{{{{{\n%($_)s\n}}}}}}\n\n" }
            (@fields))
            }
        )->format({args => { map { my $name = $_;
                        ($name => $self->_stringify_value($name)) }
                    @fields
                }})
    );
}

=head2 $trapper->field_like($what, $regex, $message)

A wrapper for L<Test::More>'s like(), that also emits more diagnostics
on failure.

=cut

sub field_like
{
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my $self = shift;
    my ($what, $regex, $name) = @_;

    if (! Test::More::like($self->$what(), $regex, $name))
    {
        $self->diag_all();
    }
}

=head2 $trapper->field_unlike($what, $regex, $msg)

A wrapper for unlike().

=cut

sub field_unlike
{
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my $self = shift;
    my ($what, $regex, $name) = @_;

    if (! Test::More::unlike($self->$what(), $regex, $name))
    {
        $self->diag_all();
    }
}

=head2 $trapper->field_is($what, $expected, $msg)

A wrapper for is().

=cut

sub field_is
{
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my $self = shift;
    my ($what, $expected, $name) = @_;

    if (! Test::More::is($self->$what(), $expected, $name))
    {
        $self->diag_all();
    }
}

=head2 $trapper->field_is_deeply($what, $expected, $msg)

A wrapper for is_deeply().

=cut

sub field_is_deeply
{
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my $self = shift;
    my ($what, $expected, $name) = @_;

    if (! Test::More::is_deeply($self->$what(), $expected, $name))
    {
        $self->diag_all();
    }
}


=head2 my $got = Test::Run::Trap::Obj->trap_run({class => $class, args => \@args, run_func => $func})

Runs C<$class->$func()> with the arguments @args placed into a hash-ref,
traps the results and returns a results object.

=cut

sub trap_run
{
    my ($class, $args) = @_;

    my $test_run_class = $args->{class} || "Test::Run::Obj";

    my $test_run_args = $args->{args};

    my $run_func = $args->{run_func} || "runtests";

    my $tester = $test_run_class->new(
        {@{$test_run_args}},
        );

    trap { $tester->$run_func(); };

    return $class->new({
        ( map { $_ => $trap->$_() }
        (qw(stdout stderr die leaveby exit return warn wantarray)))
    });
}

1;

=head1 AUTHOR

Shlomi Fish, L<http://www.shlomifish.org/>.

=head1 LICENSE

This file is licensed under the MIT X11 License:

http://www.opensource.org/licenses/mit-license.php

=head1 SEE ALSO

L<Test::Trap> , L<Test::More> .

=cut