ext/Test/Harness/lib/TAP/Formatter/Color.pm

   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.14
  75
  76 =cut
  77
  78 $VERSION = '3.14';
  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;