Update Test-Harness to CPAN version 3.39
[perl.git] / cpan / Test-Harness / lib / TAP / Formatter / Console.pm
1 package TAP::Formatter::Console;
2
3 use strict;
4 use warnings;
5 use base 'TAP::Formatter::Base';
6 use POSIX qw(strftime);
7
8 =head1 NAME
9
10 TAP::Formatter::Console - Harness output delegate for default console output
11
12 =head1 VERSION
13
14 Version 3.39
15
16 =cut
17
18 our $VERSION = '3.39';
19
20 =head1 DESCRIPTION
21
22 This 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
31 See L<TAP::Formatter::Base>
32
33 =cut
34
35 sub 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
60 sub _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
70 sub _failure_color {
71     my ($self) = @_;
72
73     return $ENV{'HARNESS_SUMMARY_COLOR_FAIL'} || 'red';
74 }
75
76 sub _success_color {
77     my ($self) = @_;
78
79     return $ENV{'HARNESS_SUMMARY_COLOR_SUCCESS'} || 'green';
80 }
81
82 sub _output_success {
83     my ( $self, $msg ) = @_;
84     $self->_set_colors( $self->_success_color() );
85     $self->_output($msg);
86     $self->_set_colors('reset');
87 }
88
89 sub _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
100 1;