xref: /openbsd-src/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Console.pm (revision 3d61058aa5c692477b6d18acfbbdb653a9930ff9)
1b39c5158Smillertpackage TAP::Formatter::Console;
2b39c5158Smillert
3b39c5158Smillertuse strict;
46fb12b70Safresh1use warnings;
56fb12b70Safresh1use base 'TAP::Formatter::Base';
6b39c5158Smillertuse POSIX qw(strftime);
7b39c5158Smillert
8b39c5158Smillert=head1 NAME
9b39c5158Smillert
10b39c5158SmillertTAP::Formatter::Console - Harness output delegate for default console output
11b39c5158Smillert
12b39c5158Smillert=head1 VERSION
13b39c5158Smillert
14*3d61058aSafresh1Version 3.48
15b39c5158Smillert
16b39c5158Smillert=cut
17b39c5158Smillert
18*3d61058aSafresh1our $VERSION = '3.48';
19b39c5158Smillert
20b39c5158Smillert=head1 DESCRIPTION
21b39c5158Smillert
22b39c5158SmillertThis provides console orientated output formatting for TAP::Harness.
23b39c5158Smillert
24b39c5158Smillert=head1 SYNOPSIS
25b39c5158Smillert
26b39c5158Smillert use TAP::Formatter::Console;
27b39c5158Smillert my $harness = TAP::Formatter::Console->new( \%args );
28b39c5158Smillert
29b39c5158Smillert=head2 C<< open_test >>
30b39c5158Smillert
31898184e3SsthenSee L<TAP::Formatter::Base>
32b39c5158Smillert
33b39c5158Smillert=cut
34b39c5158Smillert
35b39c5158Smillertsub open_test {
36b39c5158Smillert    my ( $self, $test, $parser ) = @_;
37b39c5158Smillert
38b39c5158Smillert    my $class
39b39c5158Smillert      = $self->jobs > 1
40b39c5158Smillert      ? 'TAP::Formatter::Console::ParallelSession'
41b39c5158Smillert      : 'TAP::Formatter::Console::Session';
42b39c5158Smillert
43b39c5158Smillert    eval "require $class";
44b39c5158Smillert    $self->_croak($@) if $@;
45b39c5158Smillert
46b39c5158Smillert    my $session = $class->new(
47b39c5158Smillert        {   name       => $test,
48b39c5158Smillert            formatter  => $self,
49b39c5158Smillert            parser     => $parser,
50b39c5158Smillert            show_count => $self->show_count,
51b39c5158Smillert        }
52b39c5158Smillert    );
53b39c5158Smillert
54b39c5158Smillert    $session->header;
55b39c5158Smillert
56b39c5158Smillert    return $session;
57b39c5158Smillert}
58b39c5158Smillert
59b39c5158Smillert# Use _colorizer delegate to set output color. NOP if we have no delegate
60b39c5158Smillertsub _set_colors {
61b39c5158Smillert    my ( $self, @colors ) = @_;
62b39c5158Smillert    if ( my $colorizer = $self->_colorizer ) {
63b39c5158Smillert        my $output_func = $self->{_output_func} ||= sub {
64b39c5158Smillert            $self->_output(@_);
65b39c5158Smillert        };
66b39c5158Smillert        $colorizer->set_color( $output_func, $_ ) for @colors;
67b39c5158Smillert    }
68b39c5158Smillert}
69b39c5158Smillert
706fb12b70Safresh1sub _failure_color {
716fb12b70Safresh1    my ($self) = @_;
726fb12b70Safresh1
736fb12b70Safresh1    return $ENV{'HARNESS_SUMMARY_COLOR_FAIL'} || 'red';
746fb12b70Safresh1}
756fb12b70Safresh1
766fb12b70Safresh1sub _success_color {
776fb12b70Safresh1    my ($self) = @_;
786fb12b70Safresh1
796fb12b70Safresh1    return $ENV{'HARNESS_SUMMARY_COLOR_SUCCESS'} || 'green';
806fb12b70Safresh1}
816fb12b70Safresh1
82b39c5158Smillertsub _output_success {
83b39c5158Smillert    my ( $self, $msg ) = @_;
846fb12b70Safresh1    $self->_set_colors( $self->_success_color() );
85b39c5158Smillert    $self->_output($msg);
86b39c5158Smillert    $self->_set_colors('reset');
87b39c5158Smillert}
88b39c5158Smillert
89b39c5158Smillertsub _failure_output {
90b39c5158Smillert    my $self = shift;
916fb12b70Safresh1    $self->_set_colors( $self->_failure_color() );
92b39c5158Smillert    my $out = join '', @_;
93b39c5158Smillert    my $has_newline = chomp $out;
94b39c5158Smillert    $self->_output($out);
95b39c5158Smillert    $self->_set_colors('reset');
96b39c5158Smillert    $self->_output($/)
97b39c5158Smillert      if $has_newline;
98b39c5158Smillert}
99b39c5158Smillert
100b39c5158Smillert1;
101