"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/TAP/Formatter/Console/Session.pm" (10 Mar 2019, 5527 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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