File Coverage

blib/lib/Test/Pretty.pm
Criterion Covered Total %
statement 65 179 36.3
branch 10 72 13.8
condition 4 29 13.7
subroutine 17 28 60.7
pod n/a
total 96 308 31.1


line stmt bran cond sub pod time code
1             package Test::Pretty;
2 3     3   19130 use strict;
  3         5  
  3         89  
3 3     3   10 use warnings;
  3         3  
  3         58  
4 3     3   52 use 5.008001;
  3         10  
  3         116  
5             our $VERSION = '0.30';
6              
7 3     3   1332 use Test::Builder 0.82;
  3         26994  
  3         96  
8 3     3   1627 use Term::Encoding ();
  3         1917  
  3         68  
9 3     3   43 use File::Spec ();
  3         5  
  3         55  
10 3     3   2344 use Term::ANSIColor ();
  3         22645  
  3         91  
11 3     3   1438 use Test::More ();
  3         9557  
  3         77  
12 3     3   1779 use Scope::Guard;
  3         1352  
  3         135  
13 3     3   44 use Carp ();
  3         3  
  3         77  
14              
15 3     3   15 use Cwd ();
  3         4  
  3         940  
16              
17 0     0   0 *colored = -t STDOUT || $ENV{PERL_TEST_PRETTY_ENABLED} ? \&Term::ANSIColor::colored : sub { $_[1] };
18              
19             my $ORIGINAL_PID = $$;
20              
21             my $SHOW_DUMMY_TAP;
22             my $TERM_ENCODING = Term::Encoding::term_encoding();
23             my $ENCODING_IS_UTF8 = $TERM_ENCODING =~ /^utf-?8$/i;
24              
25             our $NO_ENDING; # Force disable the Test::Pretty finalization process.
26              
27             my $ORIGINAL_subtest = \&Test::Builder::subtest;
28              
29             our $BASE_DIR = Cwd::getcwd();
30             my %filecache;
31             my $get_src_line = sub {
32             my ($filename, $lineno) = @_;
33             $filename = File::Spec->rel2abs($filename, $BASE_DIR);
34             # read a source as utf-8... Yes. it's bad. but works for most of users.
35             # I may need to remove binmode for STDOUT?
36             my $lines = $filecache{$filename} ||= sub {
37             # :encoding is likely to override $@
38             local $@;
39             open my $fh, "<:encoding(utf-8)", $filename
40             or return '';
41             [<$fh>]
42             }->();
43             return unless ref $lines eq 'ARRAY';
44             my $line = $lines->[$lineno-1];
45             $line =~ s/^\s+|\s+$//g;
46             return $line;
47             };
48              
49             if ((!$ENV{HARNESS_ACTIVE} || $ENV{PERL_TEST_PRETTY_ENABLED})) {
50             # make pretty
51 3     3   20 no warnings 'redefine';
  3         5  
  3         1256  
52             *Test::Builder::subtest = \&_subtest;
53             *Test::Builder::ok = \&_ok;
54             *Test::Builder::done_testing = \&_done_testing;
55             *Test::Builder::skip = \&_skip;
56             *Test::Builder::skip_all = \&_skip_all;
57             *Test::Builder::expected_tests = \&_expected_tests;
58              
59             my %plan_cmds = (
60             no_plan => \&Test::Builder::no_plan,
61             skip_all => \&_skip_all,
62             tests => \&__plan_tests,
63             );
64             *Test::Builder::plan = sub {
65             my( $self, $cmd, $arg ) = @_;
66              
67             return unless $cmd;
68              
69             local $Test::Builder::Level = $Test::Builder::Level + 1;
70              
71             $self->croak("You tried to plan twice") if $self->{Have_Plan};
72              
73             if( my $method = $plan_cmds{$cmd} ) {
74             local $Test::Builder::Level = $Test::Builder::Level + 1;
75             $self->$method($arg);
76             }
77             else {
78             my @args = grep { defined } ( $cmd, $arg );
79             $self->croak("plan() doesn't understand @args");
80             }
81              
82             return 1;
83             };
84              
85             my $builder = Test::Builder->new;
86             $builder->no_ending(1);
87             $builder->no_header(1); # plan
88              
89             binmode $builder->output(), "encoding($TERM_ENCODING)";
90             binmode $builder->failure_output(), "encoding($TERM_ENCODING)";
91             binmode $builder->todo_output(), "encoding($TERM_ENCODING)";
92              
93             if ($ENV{HARNESS_ACTIVE}) {
94             $SHOW_DUMMY_TAP++;
95             }
96             } else {
97 3     3   22 no warnings 'redefine';
  3         5  
  3         4733  
98             my $ORIGINAL_ok = \&Test::Builder::ok;
99             my @NAMES;
100              
101             $|++;
102              
103             my $builder = Test::Builder->new;
104 3     3   110 binmode $builder->output(), "encoding($TERM_ENCODING)";
  3         4  
  3         22  
105             binmode $builder->failure_output(), "encoding($TERM_ENCODING)";
106             binmode $builder->todo_output(), "encoding($TERM_ENCODING)";
107              
108             my ($arrow_mark, $failed_mark);
109             if ($ENCODING_IS_UTF8) {
110             $arrow_mark = "\x{bb}";
111             $failed_mark = " \x{2192} ";
112             } else {
113             $arrow_mark = ">>";
114             $failed_mark = " x ";
115             }
116              
117             *Test::Builder::subtest = sub {
118 0     0   0 push @NAMES, $_[1];
119             my $guard = Scope::Guard->new(sub {
120 0     0   0 pop @NAMES;
121 0         0 });
122 0         0 $_[0]->note(colored(['cyan'], $arrow_mark x (@NAMES*2)) . " " . join(colored(['yellow'], $failed_mark), $NAMES[-1]));
123 0         0 $_[2]->();
124             };
125             *Test::Builder::ok = sub {
126 4     4   252711 my @args = @_;
127 4   66     34 $args[2] ||= do {
128 3         37 my ( $package, $filename, $line ) = caller($Test::Builder::Level);
129 3         25 "L $line: " . $get_src_line->($filename, $line);
130             };
131 4 50       19 if (@NAMES) {
132 0         0 $args[2] = "(" . join( '/', @NAMES) . ") " . $args[2];
133             }
134 4         12 local $Test::Builder::Level = $Test::Builder::Level + 1;
135 4         30 &$ORIGINAL_ok(@_);
136             };
137             }
138              
139             END {
140 3     3   3473 my $builder = Test::Builder->new;
141 3         86 my $real_exit_code = $?;
142              
143             # Don't bother with an ending if this is a forked copy. Only the parent
144             # should do the ending.
145 3 100       64 if( $ORIGINAL_PID!= $$ ) {
146 1         24 goto NO_ENDING;
147             }
148 2 50       13 if ($Test::Pretty::NO_ENDING) {
149 0         0 goto NO_ENDING;
150             }
151              
152             # see Test::Builder::_ending
153 2 50 33     19 if( !$builder->{Have_Plan} and $builder->{Curr_Test} ) {
154 0         0 $builder->is_passing(0);
155 0         0 $builder->diag("Tests were run but no plan was declared and done_testing() was not seen.");
156             }
157              
158 2 50 33     34 if ($builder->{Have_Plan} && !$builder->{No_Plan}) {
159 2 50       13 if ($builder->{Curr_Test} != $builder->{Expected_Tests}) {
160 0         0 $builder->diag("Bad plan: $builder->{Curr_Test} != $builder->{Expected_Tests}");
161 0         0 $builder->is_passing(0);
162             }
163             }
164 2 50       22 if ($SHOW_DUMMY_TAP) {
165 0 0 0     0 printf("\n%s\n", ($?==0 && $builder->is_passing) ? 'ok' : 'not ok');
166             }
167 2 50       13 if (!$real_exit_code) {
168 2 50       15 if ($builder->is_passing) {
169             ## no critic (Variables::RequireLocalizedPunctuationVars)
170 2         25 $? = 0;
171             } else {
172             # TODO: exit status may be 'how many failed'
173             ## no critic (Variables::RequireLocalizedPunctuationVars)
174 0         0 $? = 1;
175             }
176             }
177             NO_ENDING:
178 3         50 }
179              
180             sub _skip_all {
181 0     0     my ($self, $reason) = @_;
182              
183 0 0         $self->{Skip_All} = $self->parent ? $reason : 1;
184              
185 0           printf("1..0 # SKIP %s\n", $reason);
186 0           $SHOW_DUMMY_TAP = 0;
187 0 0         if ( $self->parent ) {
188 0           die bless {} => 'Test::Builder::Exception';
189             }
190 0           exit(0);
191             }
192              
193             sub _ok {
194 0     0     my( $self, $test, $name ) = @_;
195              
196 0           my ($pkg, $filename, $line, $sub) = caller($Test::Builder::Level);
197 0           my $src_line;
198 0 0         if (defined($line)) {
199 0           $src_line = $get_src_line->($filename, $line);
200             } else {
201 0           $self->diag(Carp::longmess("\$Test::Builder::Level is invalid. Testing library you are using is broken. : $Test::Builder::Level"));
202 0           $src_line = '';
203             }
204              
205 0 0 0       if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
206 0 0         $name = 'unnamed test' unless defined $name;
207 0           $self->is_passing(0);
208 0           $self->croak("Cannot run test ($name) with active children");
209             }
210             # $test might contain an object which we don't want to accidentally
211             # store, so we turn it into a boolean.
212 0 0         $test = $test ? 1 : 0;
213              
214 0           lock $self->{Curr_Test};
215 0           $self->{Curr_Test}++;
216              
217             # In case $name is a string overloaded object, force it to stringify.
218 0           $self->_unoverload_str( \$name );
219              
220 0 0 0       $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
221             You named your test '$name'. You shouldn't use numbers for your test names.
222             Very confusing.
223             ERR
224              
225             # Capture the value of $TODO for the rest of this ok() call
226             # so it can more easily be found by other routines.
227 0           my $todo = $self->todo();
228 0           my $in_todo = $self->in_todo;
229 0 0         local $self->{Todo} = $todo if $in_todo;
230              
231 0           $self->_unoverload_str( \$todo );
232              
233 0           my $out;
234 0           my $result = &Test::Builder::share( {} );
235              
236              
237 0 0         unless($test) {
238 0 0         my $fail_char = $ENCODING_IS_UTF8 ? "\x{2716}" : "x";
239 0           $out .= colored(['red'], $fail_char);
240 0 0         @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
241             }
242             else {
243 0 0         my $success_char = $ENCODING_IS_UTF8 ? "\x{2713}" : "o";
244 0           $out .= colored(['green'], $success_char);
245 0           @$result{ 'ok', 'actual_ok' } = ( 1, $test );
246             }
247              
248 0   0       $name ||= " L$line: $src_line";
249              
250             # $out .= " $self->{Curr_Test}" if $self->use_numbers;
251              
252 0 0         if( defined $name ) {
253 0           $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
254 0   0       $out .= colored([$ENV{TEST_PRETTY_COLOR_NAME} || 'BRIGHT_BLACK'], " $name");
255 0           $result->{name} = $name;
256             }
257             else {
258 0           $result->{name} = '';
259             }
260              
261 0 0         if( $self->in_todo ) {
262 0           $out .= " # TODO $todo";
263 0           $result->{reason} = $todo;
264 0           $result->{type} = 'todo';
265             }
266             else {
267 0           $result->{reason} = '';
268 0           $result->{type} = '';
269             }
270              
271 0           $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
272 0           $out .= "\n";
273              
274             # Dont print 'ok's for subtests. It's not pretty.
275 0 0 0       $self->_print($out) unless $sub =~/subtest/ and $test;
276              
277 0 0         unless($test) {
278 0 0         my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
279 0 0         $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
280              
281 0           my( undef, $file, $line ) = $self->caller;
282 0 0         if( defined $name ) {
283 0           $self->diag(qq[ $msg test '$name'\n]);
284 0           $self->diag(qq[ at $file line $line.\n]);
285             }
286             else {
287 0           $self->diag(qq[ $msg test at $file line $line.\n]);
288             }
289             }
290              
291 0 0 0       $self->is_passing(0) unless $test || $self->in_todo;
292              
293             # Check that we haven't violated the plan
294 0           $self->_check_is_passing_plan();
295              
296 0 0         return $test ? 1 : 0;
297             }
298              
299             sub _done_testing {
300             # do nothing
301 0     0     my $builder = Test::More->builder;
302 0           $builder->{Have_Plan} = 1;
303 0           $builder->{Done_Testing} = [caller];
304 0           $builder->{Expected_Tests} = $builder->current_test;
305             }
306              
307             sub _subtest {
308 0     0     my ($self, $name) = @_;
309 0           my $orig_indent = $self->_indent();
310 0           my $ORIGINAL_note = \&Test::Builder::note;
311 3     3   25 no warnings 'redefine';
  3         5  
  3         1614  
312             *Test::Builder::note = sub {
313             # Not sure why the output looses its encoding but lets set it back again.
314             # Otherwise we get "Wide character in print" errors.
315 0     0     binmode $_[0]->output(), "encoding($TERM_ENCODING)";
316             # If printing the beginning of a subtest, make it pretty
317 0 0         if ( $_[1] eq "Subtest: $name") {
318 0           print {$self->output} do {
  0            
319 0           $orig_indent . " $name\n";
320             };
321 0           return 0;
322             } else {
323 0           $ORIGINAL_note->(@_);
324             }
325 0           };
326             # Now that we've redefined note(), let Test::Builder run as normal.
327 0           my $retval = $ORIGINAL_subtest->(@_);
328 0           *Test::Builder::note = $ORIGINAL_note;
329 0           $retval;
330             }
331              
332             sub __plan_tests {
333 0     0     my ( $self, $arg ) = @_;
334              
335 0 0         if ($arg) {
    0          
336 0           local $Test::Builder::Level = $Test::Builder::Level + 1;
337 0           return $self->expected_tests($arg);
338             }
339             elsif ( !defined $arg ) {
340 0           $self->croak("Got an undefined number of tests");
341             }
342             else {
343 0           $self->croak("You said to run 0 tests");
344             }
345              
346 0           return;
347             }
348              
349             sub _expected_tests {
350 0     0     my $self = shift;
351 0           my($max) = @_;
352              
353 0 0         if(@_) {
354 0 0         $self->croak("Number of tests must be a positive integer. You gave it '$max'")
355             unless $max =~ /^\+?\d+$/;
356              
357 0           $self->{Expected_Tests} = $max;
358 0           $self->{Have_Plan} = 1;
359              
360             # $self->_output_plan($max) unless $self->no_header;
361             }
362 0           return $self->{Expected_Tests};
363             }
364              
365             sub _skip {
366 0     0     my ($self, $why) = @_;
367              
368 0           lock( $self->{Curr_Test} );
369 0           $self->{Curr_Test}++;
370              
371 0           $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &Test::Builder::share(
372             {
373             'ok' => 1,
374             actual_ok => 1,
375             name => '',
376             type => 'skip',
377             reason => $why,
378             }
379             );
380              
381 0           $self->_print(colored(['yellow'], 'skip') . " $why");
382              
383 0           return 1;
384             }
385              
386             1;
387             __END__