Commit | Line | Data |
3fea05b9 |
1 | package TAP::Formatter::Color; |
2 | |
3 | use strict; |
4 | use vars qw($VERSION @ISA); |
5 | |
6 | use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); |
7 | |
8 | @ISA = qw(TAP::Object); |
9 | |
10 | my $NO_COLOR; |
11 | |
12 | BEGIN { |
13 | $NO_COLOR = 0; |
14 | |
15 | if (IS_WIN32) { |
16 | eval 'use Win32::Console'; |
17 | if ($@) { |
18 | $NO_COLOR = $@; |
19 | } |
20 | else { |
21 | my $console = Win32::Console->new( STD_OUTPUT_HANDLE() ); |
22 | |
23 | # eval here because we might not know about these variables |
24 | my $fg = eval '$FG_LIGHTGRAY'; |
25 | my $bg = eval '$BG_BLACK'; |
26 | |
27 | *set_color = sub { |
28 | my ( $self, $output, $color ) = @_; |
29 | |
30 | my $var; |
31 | if ( $color eq 'reset' ) { |
32 | $fg = eval '$FG_LIGHTGRAY'; |
33 | $bg = eval '$BG_BLACK'; |
34 | } |
35 | elsif ( $color =~ /^on_(.+)$/ ) { |
36 | $bg = eval '$BG_' . uc($1); |
37 | } |
38 | else { |
39 | $fg = eval '$FG_' . uc($color); |
40 | } |
41 | |
42 | # In case of colors that aren't defined |
43 | $self->set_color('reset') |
44 | unless defined $bg && defined $fg; |
45 | |
46 | $console->Attr( $bg | $fg ); |
47 | }; |
48 | } |
49 | } |
50 | else { |
51 | eval 'use Term::ANSIColor'; |
52 | if ($@) { |
53 | $NO_COLOR = $@; |
54 | } |
55 | else { |
56 | *set_color = sub { |
57 | my ( $self, $output, $color ) = @_; |
58 | $output->( color($color) ); |
59 | }; |
60 | } |
61 | } |
62 | |
63 | if ($NO_COLOR) { |
64 | *set_color = sub { }; |
65 | } |
66 | } |
67 | |
68 | =head1 NAME |
69 | |
70 | TAP::Formatter::Color - Run Perl test scripts with color |
71 | |
72 | =head1 VERSION |
73 | |
74 | Version 3.17 |
75 | |
76 | =cut |
77 | |
78 | $VERSION = '3.17'; |
79 | |
80 | =head1 DESCRIPTION |
81 | |
82 | Note that this harness is I<experimental>. You may not like the colors I've |
83 | chosen and I haven't yet provided an easy way to override them. |
84 | |
85 | This test harness is the same as L<TAP::Harness>, but test results are output |
86 | in color. Passing tests are printed in green. Failing tests are in red. |
87 | Skipped tests are blue on a white background and TODO tests are printed in |
88 | white. |
89 | |
90 | If L<Term::ANSIColor> cannot be found (or L<Win32::Console> if running |
91 | under Windows) tests will be run without color. |
92 | |
93 | =head1 SYNOPSIS |
94 | |
95 | use TAP::Formatter::Color; |
96 | my $harness = TAP::Formatter::Color->new( \%args ); |
97 | $harness->runtests(@tests); |
98 | |
99 | =head1 METHODS |
100 | |
101 | =head2 Class Methods |
102 | |
103 | =head3 C<new> |
104 | |
105 | The constructor returns a new C<TAP::Formatter::Color> object. If |
106 | L<Term::ANSIColor> is not installed, returns undef. |
107 | |
108 | =cut |
109 | |
110 | # new() implementation supplied by TAP::Object |
111 | |
112 | sub _initialize { |
113 | my $self = shift; |
114 | |
115 | if ($NO_COLOR) { |
116 | |
117 | # shorten that message a bit |
118 | ( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s; |
119 | warn "Note: Cannot run tests in color: $error\n"; |
120 | return; # abort object construction |
121 | } |
122 | |
123 | return $self; |
124 | } |
125 | |
126 | ############################################################################## |
127 | |
128 | =head3 C<can_color> |
129 | |
130 | Test::Formatter::Color->can_color() |
131 | |
132 | Returns a boolean indicating whether or not this module can actually |
133 | generate colored output. This will be false if it could not load the |
134 | modules needed for the current platform. |
135 | |
136 | =cut |
137 | |
138 | sub can_color { |
139 | return !$NO_COLOR; |
140 | } |
141 | |
142 | =head3 C<set_color> |
143 | |
144 | Set the output color. |
145 | |
146 | =cut |
147 | |
148 | 1; |