File Coverage

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

Criterion	Covered	Total	%
statement	99	100	99.0
branch	10	12	83.3
condition	3	3	100.0
subroutine	36	36	100.0
pod	12	12	100.0
total	160	163	98.1

package Test::Run::Obj::TotObj;

use strict;
use warnings;

=head1 NAME

Test::Run::Obj::TotObj - totals encountered for the entire Test::Run session

=head1 DESCRIPTION

Inherits from L<Test::Run::Base::Struct>.

=head1 METHODS

=cut

use vars qw(@fields @counter_fields %counter_fields_map);

use Benchmark qw();

use Moose;
use MRO::Compat;

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

@counter_fields = (qw(
    bad
    bench
    bonus
    files
    good
    max
    ok
    skipped
    sub_skipped
    todo
));

%counter_fields_map = (map { $_ => 1 } @counter_fields);

has 'bad' => (is => "rw", isa => "Num");
has 'bench' => (is => "rw", isa => "Any");
has 'bonus' => (is => "rw", isa => "Str");
# TODO : Should this be removed?
has 'files' => (is => "rw");
has 'good' => (is => "rw", isa => "Num");
has 'max' => (is => "rw", isa => "Num");
has 'ok' => (is => "rw", isa => "Num");
has 'skipped' => (is => "rw", isa => "Num");
has 'sub_skipped' => (is => "rw", isa => "Num");
has 'todo' => (is => "rw", isa => "Num");
has 'tests' => (is => "rw", isa => "Num");

sub _pre_init
{
    my $self = shift;
    foreach my $f (@counter_fields)
    {
        $self->$f(0);
    }
    return 0;
}

=head2 BUILD

For Moose.

=cut

sub BUILD
{
    my $self = shift;

    $self->_register_obj_formatter(
        {
            name => "fail_no_tests_output",
            format => "FAILED--%(tests)d test %(_num_scripts)s could be run, alas--no output ever seen\n",
        },
    );

    $self->_register_obj_formatter(
        {
            name => "sub_skipped_msg",
            format => "%(sub_skipped)d %(_skipped_subtests)s",
        },
    );

    $self->_register_obj_formatter(
        {
            name => "skipped_bonusmsg_on_skipped",
            format => ", %(skipped)d %(_skipped_tests_str)s%(_and_skipped_msg)s skipped",
        },
    );

    $self->_register_obj_formatter(
        {
            name => "skipped_bonusmsg_on_sub_skipped",
            format => ", %(_sub_skipped_msg)s skipped",
        },
    );

    $self->_register_obj_formatter(
        {
            name => "sub_percent_msg",
            format => " %(_not_ok)s/%(max)s subtests failed, %(_percent_ok).2f%% okay.",
        },
    );

    $self->_register_obj_formatter(
        {
            name => "good_percent_msg",
            format => "%(_good_percent).2f",
        },
    );

    $self->_register_obj_formatter(
        {
            name => "fail_tests_good_percent_string",
            format => ", %(good_percent_msg)s%% okay",
        },
    );

    $self->_register_obj_formatter(
        {
            name => "positive_bonusmsg",
            format => " (%(bonus)s %(_bonus_subtests_str)s UNEXPECTEDLY SUCCEEDED)",
        },
    );

    return $self;
}

sub _good_percent
{
    my $self = shift;

    return $self->_percent("good", "tests");
}

sub _percent
{
    my ($self, $num, $denom) = @_;

    return ($self->$num() * 100 / $self->$denom());
}

=head2 $self->add($field, $diff)

Adds the difference $diff to the slot $field, assuming it is a counter field.

=cut

sub add
{
    my ($self, $field, $diff) = @_;
    if (!exists($counter_fields_map{$field}))
    {
        Carp::confess "Cannot add to field \"$field\"!";
    }
    $self->$field($self->$field() + $diff);
    return $self->$field();
}

=head2 $self->inc($field)

Increments the field $field by 1.

=cut

sub inc
{
    my ($self, $field) = @_;

    return $self->add($field, 1);
}

=head2 $self->bench_timestr()

Retrieves the timestr() "nop" according to Benchmark.pm of the bench() field.

=cut

sub bench_timestr
{
    my $self = shift;

    return Benchmark::timestr($self->bench(), 'nop');
}

=head2 $self->all_ok()

Returns a boolean value - 0 or 1 if all tests were OK.

=cut

sub all_ok
{
    my $self = shift;

    return $self->_normalize_cond(
           ($self->bad() == 0)
        && ($self->max() || $self->skipped())
    );
}

sub _normalize_cond
{
    my ($self, $cond) = @_;
    return ($cond ? 1 : 0);
}

=head2 $self->fail_test_scripts_string()

Internal use.

=cut

sub fail_test_scripts_string
{
    my $self = shift;

    return $self->_get_obj_formatter(
        "%(bad)s/%(tests)s test scripts",
    )->obj_format($self);
}

=head2 $self->add_results($results)

Adds the sums from a results object.

=cut

sub add_results
{
    my ($self, $results) = @_;

    foreach my $type (qw(bonus max ok todo))
    {
        $self->add($type, $results->$type());
    }

    $self->add("sub_skipped", $results->skip())
}

sub _num_scripts
{
    my $self = shift;

    return $self->_pluralize("script", $self->tests());
}

sub _get_fail_no_tests_output_text
{
    my $self = shift;

    return $self->_format_self(
        "fail_no_tests_output",
    );
}

sub _skipped_subtests
{
    my $self = shift;

    return $self->_pluralize("subtest", $self->sub_skipped());
}

=head2 $self->get_sub_skipped_msg()

Calculates the sub-skipped message ("X subtest/s")

=cut

sub _sub_skipped_msg
{
    my $self = shift;

    return $self->_format_self(
        "sub_skipped_msg",
    );
}

sub _skipped_tests_str
{
    my $self = shift;

    return $self->_pluralize("test", $self->skipped());
}

sub _and_skipped_msg
{
    my $self = shift;

    return $self->sub_skipped()
        ? ( " and " . $self->_sub_skipped_msg() )
        :   ""
        ;
}

sub _get_skipped_bonusmsg_on_skipped
{
    my $self = shift;

    return $self->_format_self(
        "skipped_bonusmsg_on_skipped"
    );
}

sub _get_skipped_bonusmsg_on_sub_skipped
{
    my $self = shift;

    return $self->_format_self(
        "skipped_bonusmsg_on_sub_skipped",
    );
}

sub _get_skipped_bonusmsg
{
    my $self = shift;

    if ($self->skipped())
    {
        return $self->_get_skipped_bonusmsg_on_skipped();
    }
    elsif ($self->sub_skipped())
    {
        return $self->_get_skipped_bonusmsg_on_sub_skipped();
    }
    else
    {
        return "";
    }
}

sub _bonus_subtests_str
{
    my $self = shift;

    return $self->_pluralize("subtest", $self->bonus());
}

sub _get_positive_bonusmsg
{
    my $self = shift;

    return $self->_format_self(
        "positive_bonusmsg"
    );
}

sub _get_subtests_bonusmsg
{
    my $self = shift;
    return ($self->bonus() ? $self->_get_positive_bonusmsg() : "");
}

=head2 $self->get_bonusmsg()

Internal use.

=cut

sub get_bonusmsg
{
    my $self = shift;

    return $self->_get_subtests_bonusmsg() . $self->_get_skipped_bonusmsg();
}

sub _percent_ok
{
    my $self = shift;

    return 100*$self->ok()/$self->max();
}

sub _not_ok
{
    my $self = shift;

    return $self->max() - $self->ok();
}

=head2 $self->get_sub_percent_msg()

Internal use.

=cut

sub get_sub_percent_msg
{
    my $self = shift;

    return $self->_format_self(
        "sub_percent_msg",
    );
}

=head2 $self->good_percent_msg()

Internal use.

=cut

sub good_percent_msg
{
    my $self = shift;

    return $self->_format_self(
        "good_percent_msg",
    );
}

=head2 $self->fail_tests_good_percent_string()

Internal use.

=cut

sub fail_tests_good_percent_string
{
    my $self = shift;

    return $self->_format_self(
        "fail_tests_good_percent_string",
    );
}

=head2 $self->benchmark_callback(\&callback)

Benchmarks the callback C<&callback> using the Benchmark module and puts the
result in the C<bench()> slot.

=cut

sub benchmark_callback
{
    my ($self, $cb) = @_;

    my $start_time = new Benchmark;
    $cb->();
    my $end_time = new Benchmark;

    $self->bench(Benchmark::timediff($end_time, $start_time));

    return;
}

1;

__END__

=head1 SEE ALSO

L<Test::Run::Base::Struct>, L<Test::Run::Obj>, L<Test::Run::Core>

=head1 LICENSE

This file is freely distributable under the MIT X11 license.

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

=head1 AUTHOR

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

=cut