local-lib5/lib/perl5/TAP/Formatter/Console/ParallelSession.pm

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