TAP::Harness::Color - Run Perl test scripts with color

TAP-Parser documentation Contained in the TAP-Parser distribution.

Index

Code Index:

NAME

Top

TAP::Harness::Color - Run Perl test scripts with color

VERSION

Top

Version 0.54

DESCRIPTION

Top

Note that this harness is 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 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 Term::ANSIColor cannot be found (or Win32::Console if running under Windows) tests will be run without color.

SYNOPSIS

Top

 use TAP::Harness::Color;
 my $harness = TAP::Harness::Color->new( \%args );
 $harness->runtests(@tests);

METHODS

Top

Class Methods

new

 my %args = (
    verbose => 1,
    lib     => [ 'lib', 'blib/lib' ],
    shuffle => 0,
 )
 my $harness = TAP::Harness::Color->new( \%args );

The constructor returns a new TAP::Harness::Color object. If Term::ANSIColor is not installed, returns a TAP::Harness object. See TAP::Harness for more details.

can_color

  Test::Harness::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.

failure_output

  $harness->failure_output(@list_of_strings_to_output);

Overrides TAP::Harness failure_output to output failure information in red.

TAP-Parser documentation Contained in the TAP-Parser distribution. 
package TAP::Harness::Color;

use strict;

use TAP::Parser;
use TAP::Harness;

use vars qw($VERSION @ISA);
@ISA = 'TAP::Harness';

use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );

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  = shift;
                my $color = shift;

                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 );
            };

           # Not sure if we'll have buffering problems using print instead
           # of $console->Write(). Don't want to override output unnecessarily
           # though and it /seems/ to work OK.
           #
           # *output = sub {
           #     my $self = shift;
           #     $console->Write($_) for @_;
           #     #print @_;
           # };
        }
    }
    else {
        eval 'use Term::ANSIColor';
        if ($@) {
            $NO_COLOR = $@;
        }
        else {
            *_set_color = sub {
                my $self  = shift;
                my $color = shift;
                $self->output( color($color) );
            };
        }
    }

    if ($NO_COLOR) {
        *_set_color = sub { };
    }
}


$VERSION = '0.54';


sub new {
    my $class = shift;
    if ($NO_COLOR) {
        warn "Cannot run tests in color: $NO_COLOR";
        return TAP::Harness->new(@_);
    }
    return $class->SUPER::new(@_);
}
##############################################################################


sub can_color {
    return !$NO_COLOR;
}

##############################################################################


sub failure_output {
    my $self = shift;
    $self->_set_colors('red');
    my $out = join( '', @_ );
    my $has_newline = chomp $out;
    $self->output($out);
    $self->_set_colors('reset');
    $self->output($/)
      if $has_newline;
}

# Set terminal color
sub _set_colors {
    my $self = shift;
    for my $color (@_) {
        $self->_set_color($color);
    }
}

sub _output_result {
    my ( $self, $parser, $result, $prev_result ) = @_;
    if ( $result->is_test ) {
        if ( !$result->is_ok ) {    # even if it's TODO
            $self->_set_colors('red');
        }
        elsif ( $result->has_skip ) {
            $self->_set_colors( 'white', 'on_blue' );

        }
        elsif ( $result->has_todo ) {
            $self->_set_colors('white');
        }
    }
    $self->SUPER::_output_result($parser, $result, $prev_result);
    $self->_set_colors('reset');
}

1;