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