xref: /openbsd-src/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Console.pm (revision 3d61058aa5c692477b6d18acfbbdb653a9930ff9)
1package TAP::Formatter::Console;
2
3use strict;
4use warnings;
5use base 'TAP::Formatter::Base';
6use POSIX qw(strftime);
7
8=head1 NAME
9
10TAP::Formatter::Console - Harness output delegate for default console output
11
12=head1 VERSION
13
14Version 3.48
15
16=cut
17
18our $VERSION = '3.48';
19
20=head1 DESCRIPTION
21
22This provides console orientated output formatting for TAP::Harness.
23
24=head1 SYNOPSIS
25
26 use TAP::Formatter::Console;
27 my $harness = TAP::Formatter::Console->new( \%args );
28
29=head2 C<< open_test >>
30
31See L<TAP::Formatter::Base>
32
33=cut
34
35sub open_test {
36    my ( $self, $test, $parser ) = @_;
37
38    my $class
39      = $self->jobs > 1
40      ? 'TAP::Formatter::Console::ParallelSession'
41      : 'TAP::Formatter::Console::Session';
42
43    eval "require $class";
44    $self->_croak($@) if $@;
45
46    my $session = $class->new(
47        {   name       => $test,
48            formatter  => $self,
49            parser     => $parser,
50            show_count => $self->show_count,
51        }
52    );
53
54    $session->header;
55
56    return $session;
57}
58
59# Use _colorizer delegate to set output color. NOP if we have no delegate
60sub _set_colors {
61    my ( $self, @colors ) = @_;
62    if ( my $colorizer = $self->_colorizer ) {
63        my $output_func = $self->{_output_func} ||= sub {
64            $self->_output(@_);
65        };
66        $colorizer->set_color( $output_func, $_ ) for @colors;
67    }
68}
69
70sub _failure_color {
71    my ($self) = @_;
72
73    return $ENV{'HARNESS_SUMMARY_COLOR_FAIL'} || 'red';
74}
75
76sub _success_color {
77    my ($self) = @_;
78
79    return $ENV{'HARNESS_SUMMARY_COLOR_SUCCESS'} || 'green';
80}
81
82sub _output_success {
83    my ( $self, $msg ) = @_;
84    $self->_set_colors( $self->_success_color() );
85    $self->_output($msg);
86    $self->_set_colors('reset');
87}
88
89sub _failure_output {
90    my $self = shift;
91    $self->_set_colors( $self->_failure_color() );
92    my $out = join '', @_;
93    my $has_newline = chomp $out;
94    $self->_output($out);
95    $self->_set_colors('reset');
96    $self->_output($/)
97      if $has_newline;
98}
99
1001;
101