lib/perl5/5.8.8/TAP/Formatter/Console/Session.pm

   1 package TAP::Formatter::Console::Session;
   2
   3 use strict;
   4 use TAP::Formatter::Session;
   5
   6 use vars qw($VERSION @ISA);
   7
   8 @ISA = qw(TAP::Formatter::Session);
   9
  10 my @ACCESSOR;
  11
  12 BEGIN {
  13     my @CLOSURE_BINDING = qw( header result clear_for_close close_test );
  14
  15     for my $method (@CLOSURE_BINDING) {
  16         no strict 'refs';
  17         *$method = sub {
  18             my $self = shift;
  19             return ( $self->{_closures} ||= $self->_closures )->{$method}
  20               ->(@_);
  21         };
  22     }
  23 }
  24
  25 =head1 NAME
  26
  27 TAP::Formatter::Console::Session - Harness output delegate for default console output
  28
  29 =head1 VERSION
  30
  31 Version 3.23
  32
  33 =cut
  34
  35 $VERSION = '3.23';
  36
  37 =head1 DESCRIPTION
  38
  39 This provides console orientated output formatting for TAP::Harness.
  40
  41 =cut
  42
  43 sub _get_output_result {
  44     my $self = shift;
  45
  46     my @color_map = (
  47         {   test => sub { $_->is_test && !$_->is_ok },
  48             colors => ['red'],
  49         },
  50         {   test => sub { $_->is_test && $_->has_skip },
  51             colors => [
  52                 'white',
  53                 'on_blue'
  54             ],
  55         },
  56         {   test => sub { $_->is_test && $_->has_todo },
  57             colors => ['yellow'],
  58         },
  59     );
  60
  61     my $formatter = $self->formatter;
  62     my $parser    = $self->parser;
  63
  64     return $formatter->_colorizer
  65       ? sub {
  66         my $result = shift;
  67         for my $col (@color_map) {
  68             local $_ = $result;
  69             if ( $col->{test}->() ) {
  70                 $formatter->_set_colors( @{ $col->{colors} } );
  71                 last;
  72             }
  73         }
  74         $formatter->_output( $self->_format_for_output($result) );
  75         $formatter->_set_colors('reset');
  76       }
  77       : sub {
  78         $formatter->_output( $self->_format_for_output(shift) );
  79       };
  80 }
  81
  82 sub _closures {
  83     my $self = shift;
  84
  85     my $parser     = $self->parser;
  86     my $formatter  = $self->formatter;
  87     my $pretty     = $formatter->_format_name( $self->name );
  88     my $show_count = $self->show_count;
  89
  90     my $really_quiet = $formatter->really_quiet;
  91     my $quiet        = $formatter->quiet;
  92     my $verbose      = $formatter->verbose;
  93     my $directives   = $formatter->directives;
  94     my $failures     = $formatter->failures;
  95     my $comments     = $formatter->comments;
  96
  97     my $output_result = $self->_get_output_result;
  98
  99     my $output          = '_output';
 100     my $plan            = '';
 101     my $newline_printed = 0;
 102
 103     my $last_status_printed = 0;
 104
 105     return {
 106         header => sub {
 107             $formatter->_output($pretty)
 108               unless $really_quiet;
 109         },
 110
 111         result => sub {
 112             my $result = shift;
 113
 114             if ( $result->is_bailout ) {
 115                 $formatter->_failure_output(
 116                         "Bailout called.  Further testing stopped:  "
 117                       . $result->explanation
 118                       . "\n" );
 119             }
 120
 121             return if $really_quiet;
 122
 123             my $is_test = $result->is_test;
 124
 125             # These are used in close_test - but only if $really_quiet
 126             # is false - so it's safe to only set them here unless that
 127             # relationship changes.
 128
 129             if ( !$plan ) {
 130                 my $planned = $parser->tests_planned || '?';
 131                 $plan = "/$planned ";
 132             }
 133             $output = $formatter->_get_output_method($parser);
 134
 135             if ( $show_count and $is_test ) {
 136                 my $number = $result->number;
 137                 my $now    = CORE::time;
 138
 139                 # Print status roughly once per second.
 140                 # We will always get the first number as a side effect of
 141                 # $last_status_printed starting with the value 0, which $now
 142                 # will never be. (Unless someone sets their clock to 1970)
 143                 if ( $last_status_printed != $now ) {
 144                     $formatter->$output("\r$pretty$number$plan");
 145                     $last_status_printed = $now;
 146                 }
 147             }
 148
 149             if (!$quiet
 150                 && (   $verbose
 151                     || ( $is_test && $failures && !$result->is_ok )
 152                     || ( $comments   && $result->is_comment )
 153                     || ( $directives && $result->has_directive ) )
 154               )
 155             {
 156                 unless ($newline_printed) {
 157                     $formatter->_output("\n");
 158                     $newline_printed = 1;
 159                 }
 160                 $output_result->($result);
 161                 $formatter->_output("\n");
 162             }
 163         },
 164
 165         clear_for_close => sub {
 166             my $spaces
 167               = ' ' x length( '.' . $pretty . $plan . $parser->tests_run );
 168             $formatter->$output("\r$spaces");
 169         },
 170
 171         close_test => sub {
 172             if ( $show_count && !$really_quiet ) {
 173                 $self->clear_for_close;
 174                 $formatter->$output("\r$pretty");
 175             }
 176
 177             # Avoid circular references
 178             $self->parser(undef);
 179             $self->{_closures} = {};
 180
 181             return if $really_quiet;
 182
 183             if ( my $skip_all = $parser->skip_all ) {
 184                 $formatter->_output("skipped: $skip_all\n");
 185             }
 186             elsif ( $parser->has_problems ) {
 187                 $self->_output_test_failure($parser);
 188             }
 189             else {
 190                 my $time_report = '';
 191                 if ( $formatter->timer ) {
 192                     my $start_time = $parser->start_time;
 193                     my $end_time   = $parser->end_time;
 194                     if ( defined $start_time and defined $end_time ) {
 195                         my $elapsed = $end_time - $start_time;
 196                         $time_report
 197                           = $self->time_is_hires
 198                           ? sprintf( ' %8d ms', $elapsed * 1000 )
 199                           : sprintf( ' %8s s', $elapsed || '<1' );
 200                     }
 201                 }
 202
 203                 $formatter->_output("ok$time_report\n");
 204             }
 205         },
 206     };
 207 }
 208
 209 =head2 C<<      clear_for_close >>
 210
 211 =head2 C<<      close_test >>
 212
 213 =head2 C<<      header >>
 214
 215 =head2 C<<      result >>
 216
 217 =cut
 218
 219 1;