File Coverage

blib/lib/Test/More/Color.pm
Criterion Covered Total %
statement 18 24 75.0
branch 3 14 21.4
condition n/a
subroutine 7 11 63.6
pod 0 6 0.0
total 28 55 50.9


line stmt bran cond sub pod time code
1            
2             package Test::More::Color;
3            
4 1     1   20041 use strict;
  1         3  
  1         40  
5 1     1   6 use warnings;
  1         3  
  1         115  
6            
7             our $VERSION = 0.040_000;
8            
9             =head1 NAME
10            
11             Test::More::Color - Very stupid TAP colorer
12            
13             =head1 SYNOPSIS
14            
15             use Test::More;
16             eval 'use Test::More::Color';
17             eval 'use Test::More::Color "foreground"';
18            
19             use_ok('Test::More::Color');
20            
21             =cut
22            
23             my ( $fg, $old_print ) = ( $ENV{TM_COLOR_FG} || 0 );
24            
25 2 50   2 0 121 sub DEBUG { $ENV{DEBUG_TM_COLOR} || 0 }
26            
27             # If exists color libĀ
28             eval { require Term::ANSIColor };
29             unless ( $@ ) {
30             DEBUG && warn __PACKAGE__, " \&Test::Builder::_print attacks";
31 1     1   5 no strict 'refs';
  1         5  
  1         35  
32 1     1   5 no warnings 'redefine';
  1         2  
  1         437  
33             $old_print = \&Test::Builder::_print;
34             *Test::Builder::_print = \&color_print;
35             *c = \&Term::ANSIColor::color;
36             }
37            
38 0 0   0 0 0 sub OK { $fg ? c("green") : c("black").c("on_green") }
39 0 0   0 0 0 sub NOT_OK { $fg ? c("red") : c("black").c("on_red"); }
40 0     0 0 0 sub RESET { c("reset"); }
41            
42             sub import {
43 1     1   14 shift;
44 1 0       26 map { /^foreground$/ and $fg = 1 } @_;
  0         0  
45             }
46            
47 0     0 0 0 sub foreground { $fg = 1; }
48            
49             sub color_print {
50 1 50   1 0 6333 DEBUG && warn __PACKAGE__, "::bgcolor_print ", $_[1];
51            
52             # Colorer if don't pipe
53 1 0       7 $_[1] =~ s/^((not)?\s*ok\s*\d+)/( $2 ? NOT_OK : OK ) . $1 . RESET/e
  0 50       0  
54             unless -p $_[0]->output;
55 1         20 $old_print->(@_);
56             }
57            
58             =head1 AUTHOR
59            
60             coolmen, C<< >>
61            
62             =head1 BUGS
63            
64             Please report any bugs or feature requests to C, or through
65             the web interface at L. I will be notified, and then you'll
66             automatically be notified of progress on your bug as I make changes.
67            
68            
69            
70            
71             =head1 SUPPORT
72            
73             You can find documentation for this module with the perldoc command.
74            
75             perldoc Test::More::Color
76            
77            
78             You can also look for information at:
79            
80             =over 4
81            
82             =item * RT: CPAN's request tracker
83            
84             L
85            
86             =item * AnnoCPAN: Annotated CPAN documentation
87            
88             L
89            
90             =item * CPAN Ratings
91            
92             L
93            
94             =item * Search CPAN
95            
96             L
97            
98             =back
99            
100            
101             =head1 LICENSE AND COPYRIGHT
102            
103             Copyright 2011 coolmen.
104            
105             This program is free software; you can redistribute it and/or modify it
106             under the terms of either: the GNU General Public License as published
107             by the Free Software Foundation; or the Artistic License.
108            
109             See http://dev.perl.org/licenses/ for more information.
110            
111            
112             =cut
113            
114             1; # End of Test::More::Color
115