File Coverage

blib/lib/TAP/Formatter/Console/ParallelSession.pm
Criterion Covered Total %
statement 21 86 24.4
branch 0 22 0.0
condition 0 11 0.0
subroutine 7 15 46.6
pod 4 4 100.0
total 32 138 23.1


line stmt bran cond sub pod time code
1             package TAP::Formatter::Console::ParallelSession;
2              
3 1     1   913 use strict;
  1         1  
  1         23  
4 1     1   3 use warnings;
  1         1  
  1         17  
5 1     1   4 use File::Spec;
  1         1  
  1         12  
6 1     1   3 use File::Path;
  1         1  
  1         39  
7 1     1   4 use Carp;
  1         2  
  1         44  
8              
9 1     1   4 use base 'TAP::Formatter::Console::Session';
  1         1  
  1         371  
10              
11 1     1   4 use constant WIDTH => 72; # Because Eric says
  1         2  
  1         637  
12              
13             my %shared;
14              
15             sub _initialize {
16 0     0     my ( $self, $arg_for ) = @_;
17              
18 0           $self->SUPER::_initialize($arg_for);
19 0           my $formatter = $self->formatter;
20              
21             # Horrid bodge. This creates our shared context per harness. Maybe
22             # TAP::Harness should give us this?
23 0   0       my $context = $shared{$formatter} ||= $self->_create_shared_context;
24 0           push @{ $context->{active} }, $self;
  0            
25              
26 0           return $self;
27             }
28              
29             sub _create_shared_context {
30 0     0     my $self = shift;
31             return {
32 0           active => [],
33             tests => 0,
34             fails => 0,
35             };
36             }
37              
38             =head1 NAME
39              
40             TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output
41              
42             =head1 VERSION
43              
44             Version 3.39
45              
46             =cut
47              
48             our $VERSION = '3.39';
49              
50             =head1 DESCRIPTION
51              
52             This provides console orientated output formatting for L
53             when run with multiple L.
54              
55             =head1 SYNOPSIS
56              
57             =cut
58              
59             =head1 METHODS
60              
61             =head2 Class Methods
62              
63             =head3 C
64              
65             Output test preamble
66              
67             =cut
68              
69       0 1   sub header {
70             }
71              
72             sub _clear_ruler {
73 0     0     my $self = shift;
74 0           $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" );
75             }
76              
77             my $now = 0;
78             my $start;
79              
80             my $trailer = '... )===';
81             my $chop_length = WIDTH - length $trailer;
82              
83             sub _output_ruler {
84 0     0     my ( $self, $refresh ) = @_;
85 0           my $new_now = time;
86 0 0 0       return if $new_now == $now and !$refresh;
87 0           $now = $new_now;
88 0   0       $start ||= $now;
89 0           my $formatter = $self->formatter;
90 0 0         return if $formatter->really_quiet;
91              
92 0           my $context = $shared{$formatter};
93              
94 0           my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start;
95              
96 0           for my $active ( @{ $context->{active} } ) {
  0            
97 0           my $parser = $active->parser;
98 0           my $tests = $parser->tests_run;
99 0   0       my $planned = $parser->tests_planned || '?';
100              
101 0           $ruler .= sprintf '%' . length($planned) . "d/$planned ", $tests;
102             }
103 0           chop $ruler; # Remove a trailing space
104 0           $ruler .= ')===';
105              
106 0 0         if ( length $ruler > WIDTH ) {
107 0           $ruler =~ s/(.{$chop_length}).*/$1$trailer/o;
108             }
109             else {
110 0           $ruler .= '=' x ( WIDTH - length($ruler) );
111             }
112 0           $formatter->_output("\r$ruler");
113             }
114              
115             =head3 C
116              
117             Called by the harness for each line of TAP it receives .
118              
119             =cut
120              
121             sub result {
122 0     0 1   my ( $self, $result ) = @_;
123 0           my $formatter = $self->formatter;
124              
125             # my $really_quiet = $formatter->really_quiet;
126             # my $show_count = $self->_should_show_count;
127              
128 0 0         if ( $result->is_test ) {
    0          
129 0           my $context = $shared{$formatter};
130 0           $context->{tests}++;
131              
132 0           my $active = $context->{active};
133 0 0         if ( @$active == 1 ) {
134              
135             # There is only one test, so use the serial output format.
136 0           return $self->SUPER::result($result);
137             }
138              
139 0           $self->_output_ruler( $self->parser->tests_run == 1 );
140             }
141             elsif ( $result->is_bailout ) {
142 0           $formatter->_failure_output(
143             "Bailout called. Further testing stopped: "
144             . $result->explanation
145             . "\n" );
146             }
147             }
148              
149             =head3 C
150              
151             =cut
152              
153             sub clear_for_close {
154 0     0 1   my $self = shift;
155 0           my $formatter = $self->formatter;
156 0 0         return if $formatter->really_quiet;
157 0           my $context = $shared{$formatter};
158 0 0         if ( @{ $context->{active} } == 1 ) {
  0            
159 0           $self->SUPER::clear_for_close;
160             }
161             else {
162 0           $self->_clear_ruler;
163             }
164             }
165              
166             =head3 C
167              
168             =cut
169              
170             sub close_test {
171 0     0 1   my $self = shift;
172 0           my $name = $self->name;
173 0           my $parser = $self->parser;
174 0           my $formatter = $self->formatter;
175 0           my $context = $shared{$formatter};
176              
177 0           $self->SUPER::close_test;
178              
179 0           my $active = $context->{active};
180              
181 0           my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active;
  0            
182              
183 0 0         die "Can't find myself" unless @pos;
184 0           splice @$active, $pos[0], 1;
185              
186 0 0         if ( @$active > 1 ) {
    0          
187 0           $self->_output_ruler(1);
188             }
189             elsif ( @$active == 1 ) {
190              
191             # Print out "test/name.t ...."
192 0           $active->[0]->SUPER::header;
193             }
194             else {
195              
196             # $self->formatter->_output("\n");
197 0           delete $shared{$formatter};
198             }
199             }
200              
201             1;