git.maemo.org Git - pkg-perl/blob - deb-src/libtest-harness-perl/libtest-harness-perl-3.12/lib/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 sub _need_refresh {
  40     my $self      = shift;
  41     my $formatter = $self->formatter;
  42     $shared{$formatter}->{need_refresh}++;
  43 }
  44
  45 =head1 NAME
  46
  47 TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output
  48
  49 =head1 VERSION
  50
  51 Version 3.12
  52
  53 =cut
  54
  55 $VERSION = '3.12';
  56
  57 =head1 DESCRIPTION
  58
  59 This provides console orientated output formatting for L<TAP::Harness::Parallel>.
  60
  61 =head1 SYNOPSIS
  62
  63 =cut
  64
  65 =head1 METHODS
  66
  67 =head2 Class Methods
  68
  69 =head3 C<header>
  70
  71 Output test preamble
  72
  73 =cut
  74
  75 sub header {
  76     my $self = shift;
  77     $self->_need_refresh;
  78 }
  79
  80 sub _refresh {
  81 }
  82
  83 sub _clear_line {
  84     my $self = shift;
  85     $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" );
  86 }
  87
  88 sub _output_ruler {
  89     my $self      = shift;
  90     my $formatter = $self->formatter;
  91     return if $formatter->really_quiet;
  92
  93     my $context = $shared{$formatter};
  94
  95     my $ruler = sprintf( "===( %7d )", $context->{tests} );
  96     $ruler .= ( '=' x ( WIDTH - length $ruler ) );
  97     $formatter->_output("\r$ruler");
  98 }
  99
 100 =head3 C<result>
 101
 102   Called by the harness for each line of TAP it receives .
 103
 104 =cut
 105
 106 sub result {
 107     my ( $self, $result ) = @_;
 108     my $parser    = $self->parser;
 109     my $formatter = $self->formatter;
 110     my $context   = $shared{$formatter};
 111
 112     $self->_refresh;
 113
 114     # my $really_quiet = $formatter->really_quiet;
 115     # my $show_count   = $self->_should_show_count;
 116     my $planned = $parser->tests_planned;
 117
 118     if ( $result->is_bailout ) {
 119         $formatter->_failure_output(
 120                 "Bailout called.  Further testing stopped:  "
 121               . $result->explanation
 122               . "\n" );
 123     }
 124
 125     if ( $result->is_test ) {
 126         $context->{tests}++;
 127
 128         my $test_print_modulus = 1;
 129         my $ceiling            = $context->{tests} / 5;
 130         $test_print_modulus *= 2 while $test_print_modulus < $ceiling;
 131
 132         unless ( $context->{tests} % $test_print_modulus ) {
 133             $self->_output_ruler;
 134         }
 135     }
 136 }
 137
 138 =head3 C<close_test>
 139
 140 =cut
 141
 142 sub close_test {
 143     my $self      = shift;
 144     my $name      = $self->name;
 145     my $parser    = $self->parser;
 146     my $formatter = $self->formatter;
 147     my $context   = $shared{$formatter};
 148
 149     unless ( $formatter->really_quiet ) {
 150         $self->_clear_line;
 151
 152         # my $output = $self->_output_method;
 153         $formatter->_output(
 154             $formatter->_format_name( $self->name ),
 155             ' '
 156         );
 157     }
 158
 159     if ( $parser->has_problems ) {
 160         $self->_output_test_failure($parser);
 161     }
 162     else {
 163         $formatter->_output("ok\n")
 164           unless $formatter->really_quiet;
 165     }
 166
 167     $self->_output_ruler;
 168
 169     # $self->SUPER::close_test;
 170     my $active = $context->{active};
 171
 172     my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active;
 173
 174     die "Can't find myself" unless @pos;
 175     splice @$active, $pos[0], 1;
 176
 177     $self->_need_refresh;
 178
 179     unless (@$active) {
 180
 181         # $self->formatter->_output("\n");
 182         delete $shared{$formatter};
 183     }
 184 }
 185
 186 1;