vcs.maemo.org Git - pkg-perl/blob - deb-src/libtest-harness-perl/libtest-harness-perl-3.12/lib/TAP/Formatter/Console/Session.pm

   1 package TAP::Formatter::Console::Session;
   2
   3 use strict;
   4 use TAP::Base;
   5
   6 use vars qw($VERSION @ISA);
   7
   8 @ISA = qw(TAP::Base);
   9
  10 my @ACCESSOR;
  11
  12 BEGIN {
  13
  14     @ACCESSOR = qw( name formatter parser );
  15
  16     for my $method (@ACCESSOR) {
  17         no strict 'refs';
  18         *$method = sub { shift->{$method} };
  19     }
  20
  21     my @CLOSURE_BINDING = qw( header result close_test );
  22
  23     for my $method (@CLOSURE_BINDING) {
  24         no strict 'refs';
  25         *$method = sub {
  26             my $self = shift;
  27             return ( $self->{_closures} ||= $self->_closures )->{$method}
  28               ->(@_);
  29         };
  30     }
  31 }
  32
  33 =head1 NAME
  34
  35 TAP::Formatter::Console::Session - Harness output delegate for default console output
  36
  37 =head1 VERSION
  38
  39 Version 3.12
  40
  41 =cut
  42
  43 $VERSION = '3.12';
  44
  45 =head1 DESCRIPTION
  46
  47 This provides console orientated output formatting for TAP::Harness.
  48
  49 =head1 SYNOPSIS
  50
  51 =cut
  52
  53 =head1 METHODS
  54
  55 =head2 Class Methods
  56
  57 =head3 C<new>
  58
  59  my %args = (
  60     formatter => $self,
  61  )
  62  my $harness = TAP::Formatter::Console::Session->new( \%args );
  63
  64 The constructor returns a new C<TAP::Formatter::Console::Session> object.
  65
  66 =over 4
  67
  68 =item * C<formatter>
  69
  70 =item * C<parser>
  71
  72 =item * C<name>
  73
  74 =back
  75
  76 =cut
  77
  78 sub _initialize {
  79     my ( $self, $arg_for ) = @_;
  80     $arg_for ||= {};
  81
  82     $self->SUPER::_initialize($arg_for);
  83     my %arg_for = %$arg_for;    # force a shallow copy
  84
  85     for my $name (@ACCESSOR) {
  86         $self->{$name} = delete $arg_for{$name};
  87     }
  88
  89     if ( my @props = sort keys %arg_for ) {
  90         $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
  91     }
  92
  93     return $self;
  94 }
  95
  96 =head3 C<header>
  97
  98 Output test preamble
  99
 100 =head3 C<result>
 101
 102 Called by the harness for each line of TAP it receives.
 103
 104 =head3 C<close_test>
 105
 106 Called to close a test session.
 107
 108 =cut
 109
 110 sub _get_output_result {
 111     my $self = shift;
 112
 113     my @color_map = (
 114         {   test => sub { $_->is_test && !$_->is_ok },
 115             colors => ['red'],
 116         },
 117         {   test => sub { $_->is_test && $_->has_skip },
 118             colors => [
 119                 'white',
 120                 'on_blue'
 121             ],
 122         },
 123         {   test => sub { $_->is_test && $_->has_todo },
 124             colors => ['yellow'],
 125         },
 126     );
 127
 128     my $formatter = $self->formatter;
 129     my $parser    = $self->parser;
 130
 131     return $formatter->_colorizer
 132       ? sub {
 133         my $result = shift;
 134         for my $col (@color_map) {
 135             local $_ = $result;
 136             if ( $col->{test}->() ) {
 137                 $formatter->_set_colors( @{ $col->{colors} } );
 138                 last;
 139             }
 140         }
 141         $formatter->_output( $result->as_string );
 142         $formatter->_set_colors('reset');
 143       }
 144       : sub {
 145         $formatter->_output( shift->as_string );
 146       };
 147 }
 148
 149 sub _closures {
 150     my $self = shift;
 151
 152     my $parser     = $self->parser;
 153     my $formatter  = $self->formatter;
 154     my $show_count = $self->_should_show_count;
 155     my $pretty     = $formatter->_format_name( $self->name );
 156
 157     my $really_quiet = $formatter->really_quiet;
 158     my $quiet        = $formatter->quiet;
 159     my $verbose      = $formatter->verbose;
 160     my $directives   = $formatter->directives;
 161     my $failures     = $formatter->failures;
 162
 163     my $output_result = $self->_get_output_result;
 164
 165     my $output          = '_output';
 166     my $plan            = '';
 167     my $newline_printed = 0;
 168
 169     my $last_status_printed = 0;
 170
 171     return {
 172         header => sub {
 173             $formatter->_output($pretty)
 174               unless $really_quiet;
 175         },
 176
 177         result => sub {
 178             my $result = shift;
 179
 180             if ( $result->is_bailout ) {
 181                 $formatter->_failure_output(
 182                         "Bailout called.  Further testing stopped:  "
 183                       . $result->explanation
 184                       . "\n" );
 185             }
 186
 187             return if $really_quiet;
 188
 189             my $is_test = $result->is_test;
 190
 191             # These are used in close_test - but only if $really_quiet
 192             # is false - so it's safe to only set them here unless that
 193             # relationship changes.
 194
 195             if ( !$plan ) {
 196                 my $planned = $parser->tests_planned || '?';
 197                 $plan = "/$planned ";
 198             }
 199             $output = $formatter->_get_output_method($parser);
 200
 201             if ( $show_count and $is_test ) {
 202                 my $number = $result->number;
 203                 my $now    = CORE::time;
 204
 205                 # Print status on first number, and roughly once per second
 206                 if (   ( $number == 1 )
 207                     || ( $last_status_printed != $now ) )
 208                 {
 209                     $formatter->$output("\r$pretty$number$plan");
 210                     $last_status_printed = $now;
 211                 }
 212             }
 213
 214             if (!$quiet
 215                 && (   ( $verbose && !$failures )
 216                     || ( $is_test && $failures && !$result->is_ok )
 217                     || ( $result->has_directive && $directives ) )
 218               )
 219             {
 220                 unless ($newline_printed) {
 221                     $formatter->_output("\n");
 222                     $newline_printed = 1;
 223                 }
 224                 $output_result->($result);
 225                 $formatter->_output("\n");
 226             }
 227         },
 228
 229         close_test => sub {
 230             return if $really_quiet;
 231
 232             if ($show_count) {
 233                 my $spaces = ' ' x
 234                   length( '.' . $pretty . $plan . $parser->tests_run );
 235                 $formatter->$output("\r$spaces\r$pretty");
 236             }
 237
 238             if ( my $skip_all = $parser->skip_all ) {
 239                 $formatter->_output("skipped: $skip_all\n");
 240             }
 241             elsif ( $parser->has_problems ) {
 242                 $self->_output_test_failure($parser);
 243             }
 244             else {
 245                 my $time_report = '';
 246                 if ( $formatter->timer ) {
 247                     my $start_time = $parser->start_time;
 248                     my $end_time   = $parser->end_time;
 249                     if ( defined $start_time and defined $end_time ) {
 250                         my $elapsed = $end_time - $start_time;
 251                         $time_report
 252                           = $self->time_is_hires
 253                           ? sprintf( ' %8d ms', $elapsed * 1000 )
 254                           : sprintf( ' %8s s', $elapsed || '<1' );
 255                     }
 256                 }
 257
 258                 $formatter->_output("ok$time_report\n");
 259             }
 260         },
 261     };
 262 }
 263
 264 sub _should_show_count {
 265
 266     # we need this because if someone tries to redirect the output, it can get
 267     # very garbled from the carriage returns (\r) in the count line.
 268     return !shift->formatter->verbose && -t STDOUT;
 269 }
 270
 271 sub _output_test_failure {
 272     my ( $self, $parser ) = @_;
 273     my $formatter = $self->formatter;
 274     return if $formatter->really_quiet;
 275
 276     my $tests_run     = $parser->tests_run;
 277     my $tests_planned = $parser->tests_planned;
 278
 279     my $total
 280       = defined $tests_planned
 281       ? $tests_planned
 282       : $tests_run;
 283
 284     my $passed = $parser->passed;
 285
 286     # The total number of fails includes any tests that were planned but
 287     # didn't run
 288     my $failed = $parser->failed + $total - $tests_run;
 289     my $exit   = $parser->exit;
 290
 291     if ( my $exit = $parser->exit ) {
 292         my $wstat = $parser->wait;
 293         my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat );
 294         $formatter->_failure_output(" Dubious, test returned $status\n");
 295     }
 296
 297     if ( $failed == 0 ) {
 298         $formatter->_failure_output(
 299             $total
 300             ? " All $total subtests passed "
 301             : ' No subtests run '
 302         );
 303     }
 304     else {
 305         $formatter->_failure_output(" Failed $failed/$total subtests ");
 306         if ( !$total ) {
 307             $formatter->_failure_output("\nNo tests run!");
 308         }
 309     }
 310
 311     if ( my $skipped = $parser->skipped ) {
 312         $passed -= $skipped;
 313         my $test = 'subtest' . ( $skipped != 1 ? 's' : '' );
 314         $formatter->_output(
 315             "\n\t(less $skipped skipped $test: $passed okay)");
 316     }
 317
 318     if ( my $failed = $parser->todo_passed ) {
 319         my $test = $failed > 1 ? 'tests' : 'test';
 320         $formatter->_output(
 321             "\n\t($failed TODO $test unexpectedly succeeded)");
 322     }
 323
 324     $formatter->_output("\n");
 325 }
 326
 327 1;