lib/TAP/Formatter/Color.pm

   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;