File Coverage

blib/lib/Test/Run/Plugin/CmdLine/Output.pm

Criterion	Covered	Total	%
statement	173	187	92.5
branch	20	26	76.9
condition	2	5	40.0
subroutine	59	63	93.6
pod	1	1	100.0
total	255	282	90.4

package Test::Run::Plugin::CmdLine::Output;

use strict;
use warnings;

use Carp;
use Benchmark qw(timestr);
use MRO::Compat;

use Moose;
extends("Test::Run::Core");

use Test::Run::Output;

=head1 NAME

Test::Run::Plugin::CmdLine::Output - the default output plugin for
Test::Run::CmdLine.

=head1 MOTIVATION

This class has gradually re-implemented all of the
L<Test::Run::Plugin::CmdLine::Output::GplArt> functionality to
avoid license complications.

=head1 METHODS

=cut

sub _get_new_output
{
    my ($self, $args) = @_;

    return Test::Run::Output->new({ Verbose => $self->Verbose(), NoTty => $self->NoTty()});
}

sub _print
{
    my ($self, $string) = @_;

    return $self->output()->print_message($string);
}

sub _named_printf
{
    my ($self, $format, $args) = @_;

    return
        $self->_print(
            $self->_format($format, $args),
        );
}

has "+output" => (lazy => 1, builder => "_get_new_output");

=head2 BUILD

For Moose.

=cut

sub BUILD
{
    my $self = shift;

    my ($args) = @_;

    {
        my %formatters =
        (
            "dubious_status" =>
                "Test returned status %(estatus)s (wstat %(wstatus)d, 0x%(wstatus)x)",
            "vms_status" =>
                "\t\t(VMS status is %(estatus)s)",
            "test_file_closing_error" =>
                "can't close %(file)s. %(error)s",
            "could_not_run_script" =>
                "can't run %(file)s. %(error)s",
            "test_file_opening_error" =>
                "can't open %(file)s. %(error)s",
            "premature_test_dubious_summary" =>
                "DIED. %(canonfailed)s",
            "report_skipped_test" =>
                "%(ml)sok%(elapsed)s\n        %(all_skipped_test_msgs)s",
            "report_all_ok_test" =>
                "%(ml)sok%(elapsed)s",
            "start_env" =>
                "# PERL5LIB=%(p5lib)s",
        );

        while (my ($id, $format) = each(%formatters))
        {
            $self->_register_formatter($id, $format);
        }
    }

    {
        my %obj_formatters =
        (
            "skipped_msg" =>
                "%(skipped)s/%(max)s skipped: %(skip_reason)s",
            "bonus_msg" =>
                "%(bonus)s/%(max)s unexpectedly succeeded",
            "report_final_stats" =>
                "Files=%(files)d, Tests=%(max)d, %(bench_timestr)s",
        );

        while (my ($id, $format) = each(%obj_formatters))
        {
            $self->_register_obj_formatter(
                { name => $id, format => $format,},
            );
        }
    }

    return 0;
}

sub _get_dubious_message_ml
{
    my $self = shift;
    return $self->last_test_obj->ml();
}

sub _get_dubious_verdict_message
{
    return "dubious";
}

sub _calc__get_dubious_message_components__callbacks
{
    my $self = shift;

    return [qw(
        _get_dubious_message_ml
        _get_dubious_verdict_message
        _get_dubious_message_line_end
        _get_dubious_status_message_indent_prefix
        _get_dubious_status_message
    )];
}

sub _get_dubious_message_components
{
    my $self = shift;

    return $self->_run_sequence([@_]);
}

sub _get_dubious_message_line_end
{
    return "\n";
}

sub _get_dubious_status_message_indent_prefix
{
    return "\t";
}

sub _get_dubious_status_message
{
    my $self = shift;

    return $self->_format("dubious_status",
        {
            estatus => $self->_get_estatus(),
            wstatus => $self->_get_wstatus(),
        }
    );
}

sub _get_dubious_message
{
    my $self = shift;

    return join("",
        @{$self->_get_dubious_message_components()}
    );
}

sub _report_dubious_summary_all_subtests_successful
{
    my $self = shift;

    $self->_print("\tafter all the subtests complete successfully");
}

sub _vms_specific_report_dubious
{
    my ($self) = @_;

    if ($^O eq "VMS")
    {
        $self->_named_printf(
            "vms_status",
            { estatus => $self->_get_estatus() },
        );
    }
}

sub _report_dubious
{
    my ($self) = @_;

    $self->_print($self->_get_dubious_message());
    $self->_vms_specific_report_dubious();
}

sub _get_leaked_files_string
{
    my ($self, $args) = @_;

    return join(" ", sort @{$args->{leaked_files}});
}

sub _report_leaked_files
{
    my ($self, $args) = @_;

    $self->_print("LEAKED FILES: " . $self->_get_leaked_files_string($args));
}

sub _handle_test_file_closing_error
{
    my ($self, $args) = @_;

    return $self->_named_printf(
        "test_file_closing_error",
        $args,
    );
}

sub _report_could_not_run_script
{
    my ($self, $args) = @_;

    return $self->_named_printf(
        "could_not_run_script",
        $args,
    );
}

sub _handle_test_file_opening_error
{
    my ($self, $args) = @_;

    return $self->_named_printf(
        "test_file_opening_error",
        $args,
    );
}

sub _get_defined_skipped_msgs
{
    my ($self, $args) = @_;

    return $self->_format("skipped_msg", { obj => $self->last_test_obj});
}

sub _get_skipped_msgs
{
    my ($self, $args) = @_;

    if ($self->last_test_obj->skipped())
    {
        return [ $self->_get_defined_skipped_msgs() ];
    }
    else
    {
        return [];
    }
}

sub _get_defined_bonus_msg
{
    my ($self, $args) = @_;

    return $self->_format("bonus_msg", { obj => $self->last_test_obj() });
}

sub _get_bonus_msgs
{
    my ($self, $args) = @_;

    return
    [
        ($self->last_test_obj->bonus()) ?
            $self->_get_defined_bonus_msg() :
            ()
    ];
}

sub _get_all_skipped_test_msgs
{
    my ($self) = @_;
    return
    [
        @{$self->_get_skipped_msgs()},
        @{$self->_get_bonus_msgs()}
    ];
}

sub _reset_output_watch
{
    my $self = shift;

    $self->output()->last_test_print(0);

    return;
}

sub _output__get_display_filename_param
{
    my ($self, $args) = @_;

    return $self->_get_test_file_display_path($args->{test_file});
}

sub _output_print_leader
{
    my ($self, $args) = @_;

    $self->output()->print_leader(
        {
            filename => $self->_output__get_display_filename_param($args),
            width => $self->width(),
        }
    );

    return;
}

sub _report_single_test_file_start_leader
{
    my ($self, $args) = @_;

    $self->_reset_output_watch($args);
    $self->_output_print_leader($args);
}

sub _report_single_test_file_start_debug
{
    my ($self, $args) = @_;

    if ($self->Debug())
    {
        $self->_print(
            "# Running: " . $self->Strap()->_command_line($self->_output_print_leader($args))
        );
    }
}

sub _report_single_test_file_start
{
    my ($self, $args) = @_;

    $self->_report_single_test_file_start_leader($args);

    $self->_report_single_test_file_start_debug($args);

    return;
}

sub _calc_test_struct_ml
{
    my $self = shift;

    return $self->output->ml;
}


sub _report_premature_test_dubious_summary
{
    my $self = shift;

    $self->_named_printf(
        "premature_test_dubious_summary",
        {
            canonfailed => $self->_ser_failed_results(),
        }
    );

    return;
}

sub _report_skipped_test
{
    my $self = shift;

    $self->_named_printf(
        "report_skipped_test",
        {
            ml => $self->last_test_obj->ml(),
            elapsed => $self->last_test_elapsed,
            all_skipped_test_msgs =>
                join(', ', @{$self->_get_all_skipped_test_msgs()}),
        }
    );
}

sub _report_all_ok_test
{
    my ($self, $args) = @_;

    $self->_named_printf(
        "report_all_ok_test",
        {
            ml => $self->last_test_obj->ml(),
            elapsed => $self->last_test_elapsed,
        }
    );
}

sub _report_failed_before_any_test_output
{
    my $self = shift;

    $self->_print("FAILED before any test output arrived");
}

sub _report_all_skipped_test
{
    my ($self, $args) = @_;

    $self->_print(
        "skipped\n        all skipped: "
        . $self->last_test_obj->get_reason()
    );
}

sub _namelenize_string
{
    my ($self, $string) = @_;

    $string =~ s/\$\{max_namelen\}/$self->max_namelen()/ge;

    return $string;
}

sub _obj_named_printf
{
    my ($self, $string, $obj) = @_;

    return
    $self->_print(
        $self->_get_obj_formatter(
            $self->_namelenize_string(
                $string,
            ),
        )->obj_format($obj)
    );
}

sub _fail_other_report_tests_print_summary
{
    my ($self, $args) = @_;

    return $self->_obj_named_printf(
        ( "%(name)-\${max_namelen}s  "
        . "%(estat)3s %(wstat)5s %(max_str)5s %(failed_str)4s "
        . "%(_defined_percent)6.2f%%  %(first_canon_string)s"
        ),
        $args->{test},
    );
}

sub _fail_other_report_test_print_rest_of_canons
{
    my ($self, $args) = @_;

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

    my $whitespace = (" " x ($self->format_columns() - $self->list_len()));

    foreach my $canon (@{$test->rest_of_canons()})
    {
        $self->_print($whitespace.$canon);
    }
}

sub _fail_other_report_test
{
    my $self = shift;
    my $script = shift;

    my $test = $self->failed_tests()->{$script};

    $test->_assign_canon_strings({ main => $self, });

    my $args_to_pass =
    {
        test => $test,
        script => $script,
    };

    $self->_fail_other_report_tests_print_summary($args_to_pass);

    $self->_fail_other_report_test_print_rest_of_canons($args_to_pass);
}

sub _calc_fail_other_bonus_message
{
    my $self = shift;

    my $message = $self->_bonusmsg() || "";
    $message =~ s{\A,\s*}{};

    return $message ? "$message." : "";
}

sub _fail_other_print_bonus_message
{
    my $self = shift;

    if (my $bonusmsg = $self->_calc_fail_other_bonus_message())
    {
        $self->_print($bonusmsg);
    }
}

sub _report_failed_with_results_seen
{
    my ($self) = @_;

    $self->_print($self->_get_failed_with_results_seen_msg());
}

sub _report_test_progress__verdict
{
    my ($self, $args) = @_;

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

    if ($totals->last_detail->ok)
    {
        $self->output->print_ml_less(
            "ok ". $totals->seen . "/" . $totals->max
        );
    }
    else
    {
        $self->output->print_ml("NOK " . $totals->seen);
    }
}

sub _report_test_progress__counter
{
    my ($self, $args) = @_;

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

    my $curr = $totals->seen;
    my $next = $self->Strap->next_test_num();

    if ($curr > $next)
    {
        $self->_print("Test output counter mismatch [test $curr]");
    }
    elsif ($curr < $next)
    {
        $self->_print(
            "Confused test output: test $curr answered after test @{[$next-1]}",
        );
    }
}

sub _report_test_progress
{
    my ($self, $args) = @_;
    $self->_report_test_progress__verdict($args);
    $self->_report_test_progress__counter($args);
}

sub _report_tap_event
{
    my ($self, $args) = @_;

    my $raw_event = $args->{event}->raw();
    if ($self->Verbose())
    {
        chomp($raw_event);
        $self->_print($raw_event);
    }
}

sub _calc_PERL5LIB
{
    my $self = shift;

    return
        +(exists($ENV{PERL5LIB}) && defined($ENV{PERL5LIB}))
            ? $ENV{PERL5LIB}
            : ""
        ;
}

sub _report_script_start_environment
{
    my $self = shift;

    if ($self->Debug())
    {
        $self->_named_printf(
            "start_env",
            { 'p5lib' => $self->_calc_PERL5LIB()},
        );
    }
}

sub _report_final_stats
{
    my $self = shift;

    return $self->_named_printf(
        "report_final_stats",
        { obj => $self->tot() },
    );
}

sub _report_success_event
{
    my ($self, $args) = @_;

    $self->_print($self->_get_success_msg());
}

sub _report_non_success_event
{
    my ($self, $args) = @_;

    confess "Unknown \$event->{type} passed to _report!";
}

sub _report
{
    my ($self, $args) = @_;

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

    if ($event->{type} eq "success")
    {
        return $self->_report_success_event($args);
    }
    else
    {
        return $self->_report_non_success_event($args);
    }
}

sub _fail_other_print_top
{
    my $self = shift;

    $self->_named_printf(
        \("%(failed)-" . $self->max_namelen() . "s%(middle)s%(list)s") ,
        {
            failed => $self->_get_format_failed_str(),
            middle => $self->_get_format_middle_str(),
            list =>   $self->_get_format_list_str(),
        }
    );

    $self->_print("-" x $self->format_columns());
}

=head1 LICENSE

This file is licensed under the MIT X11 License.

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

=cut

1;