cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm

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