The Perl and Raku Conference 2025: Greenville, South Carolina - June 27-29 Learn more

ANDYA / Test-Harness-3.17 / lib / TAP / Formatter / Color.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
—
67
68
69
70
71
72
73
74
75
76
77
78
—
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
—
127
128
129
130
131
132
133
134
135
136
137
138
139
140
—
141
142
143
144
145
146
147
148

              
package TAP::Formatter::Color;
use strict;
use vars qw($VERSION @ISA);
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
@ISA = qw(TAP::Object);
my $NO_COLOR;
BEGIN {
    $NO_COLOR = 0;
    if (IS_WIN32) {
        eval 'use Win32::Console';
        if ($@) {
            $NO_COLOR = $@;
        }
        else {
            my $console = Win32::Console->new( STD_OUTPUT_HANDLE() );
            # eval here because we might not know about these variables
            my $fg = eval '$FG_LIGHTGRAY';
            my $bg = eval '$BG_BLACK';
            *set_color = sub {
                my ( $self, $output, $color ) = @_;
                my $var;
                if ( $color eq 'reset' ) {
                    $fg = eval '$FG_LIGHTGRAY';
                    $bg = eval '$BG_BLACK';
                }
                elsif ( $color =~ /^on_(.+)$/ ) {
                    $bg = eval '$BG_' . uc($1);
                }
                else {
                    $fg = eval '$FG_' . uc($color);
                }
                # In case of colors that aren't defined
                $self->set_color('reset')
                  unless defined $bg && defined $fg;
                $console->Attr( $bg | $fg );
            };
        }
    }
    else {
        eval 'use Term::ANSIColor';
        if ($@) {
            $NO_COLOR = $@;
        }
        else {
            *set_color = sub {
                my ( $self, $output, $color ) = @_;
                $output->( color($color) );
            };
        }
    }
    if ($NO_COLOR) {
        *set_color = sub { };
    }
}
=head1 NAME
TAP::Formatter::Color - Run Perl test scripts with color
=head1 VERSION
Version 3.17
=cut
$VERSION = '3.17';
=head1 DESCRIPTION
Note that this harness is I<experimental>.  You may not like the colors I've
chosen and I haven't yet provided an easy way to override them.
This test harness is the same as L<TAP::Harness>, but test results are output
in color.  Passing tests are printed in green.  Failing tests are in red.
Skipped tests are blue on a white background and TODO tests are printed in
white.
If L<Term::ANSIColor> cannot be found (or L<Win32::Console> if running
under Windows) tests will be run without color.
=head1 SYNOPSIS
 use TAP::Formatter::Color;
 my $harness = TAP::Formatter::Color->new( \%args );
 $harness->runtests(@tests);
=head1 METHODS
=head2 Class Methods
=head3 C<new>
The constructor returns a new C<TAP::Formatter::Color> object. If
L<Term::ANSIColor> is not installed, returns undef.
=cut
# new() implementation supplied by TAP::Object
sub _initialize {
    my $self = shift;
    if ($NO_COLOR) {
        # shorten that message a bit
        ( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s;
        warn "Note: Cannot run tests in color: $error\n";
        return;    # abort object construction
    }
    return $self;
}
##############################################################################
=head3 C<can_color>
  Test::Formatter::Color->can_color()
Returns a boolean indicating whether or not this module can actually
generate colored output. This will be false if it could not load the
modules needed for the current platform.
=cut
sub can_color {
    return !$NO_COLOR;
}
=head3 C<set_color>
Set the output color.
=cut
1;