"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/TAP/Formatter/Base.pm" (10 Mar 2019, 11870 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::Base;
    2 
    3 use strict;
    4 use warnings;
    5 use base 'TAP::Base';
    6 use POSIX qw(strftime);
    7 
    8 my $MAX_ERRORS = 5;
    9 my %VALIDATION_FOR;
   10 
   11 BEGIN {
   12     %VALIDATION_FOR = (
   13         directives => sub { shift; shift },
   14         verbosity  => sub { shift; shift },
   15         normalize  => sub { shift; shift },
   16         timer      => sub { shift; shift },
   17         failures   => sub { shift; shift },
   18         comments   => sub { shift; shift },
   19         errors     => sub { shift; shift },
   20         color      => sub { shift; shift },
   21         jobs       => sub { shift; shift },
   22         show_count => sub { shift; shift },
   23         stdout     => sub {
   24             my ( $self, $ref ) = @_;
   25 
   26             $self->_croak("option 'stdout' needs a filehandle")
   27               unless $self->_is_filehandle($ref);
   28 
   29             return $ref;
   30         },
   31     );
   32 
   33     sub _is_filehandle {
   34         my ( $self, $ref ) = @_;
   35 
   36         return 0 if !defined $ref;
   37 
   38         return 1 if ref $ref eq 'GLOB';    # lexical filehandle
   39         return 1 if !ref $ref && ref \$ref eq 'GLOB'; # bare glob like *STDOUT
   40 
   41         return 1 if eval { $ref->can('print') };
   42 
   43         return 0;
   44     }
   45 
   46     my @getter_setters = qw(
   47       _longest
   48       _printed_summary_header
   49       _colorizer
   50     );
   51 
   52     __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR );
   53 }
   54 
   55 =head1 NAME
   56 
   57 TAP::Formatter::Base - Base class for harness output delegates
   58 
   59 =head1 VERSION
   60 
   61 Version 3.42
   62 
   63 =cut
   64 
   65 our $VERSION = '3.42';
   66 
   67 =head1 DESCRIPTION
   68 
   69 This provides console orientated output formatting for TAP::Harness.
   70 
   71 =head1 SYNOPSIS
   72 
   73  use TAP::Formatter::Console;
   74  my $harness = TAP::Formatter::Console->new( \%args );
   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     $self->verbosity(0);
   86 
   87     for my $name ( keys %VALIDATION_FOR ) {
   88         my $property = delete $arg_for{$name};
   89         if ( defined $property ) {
   90             my $validate = $VALIDATION_FOR{$name};
   91             $self->$name( $self->$validate($property) );
   92         }
   93     }
   94 
   95     if ( my @props = keys %arg_for ) {
   96         $self->_croak(
   97             "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
   98     }
   99 
  100     $self->stdout( \*STDOUT ) unless $self->stdout;
  101 
  102     if ( $self->color ) {
  103         require TAP::Formatter::Color;
  104         $self->_colorizer( TAP::Formatter::Color->new );
  105     }
  106 
  107     return $self;
  108 }
  109 
  110 sub verbose      { shift->verbosity >= 1 }
  111 sub quiet        { shift->verbosity <= -1 }
  112 sub really_quiet { shift->verbosity <= -2 }
  113 sub silent       { shift->verbosity <= -3 }
  114 
  115 =head1 METHODS
  116 
  117 =head2 Class Methods
  118 
  119 =head3 C<new>
  120 
  121  my %args = (
  122     verbose => 1,
  123  )
  124  my $harness = TAP::Formatter::Console->new( \%args );
  125 
  126 The constructor returns a new C<TAP::Formatter::Console> object. If
  127 a L<TAP::Harness> is created with no C<formatter> a
  128 C<TAP::Formatter::Console> is automatically created. If any of the
  129 following options were given to TAP::Harness->new they well be passed to
  130 this constructor which accepts an optional hashref whose allowed keys are:
  131 
  132 =over 4
  133 
  134 =item * C<verbosity>
  135 
  136 Set the verbosity level.
  137 
  138 =item * C<verbose>
  139 
  140 Printing individual test results to STDOUT.
  141 
  142 =item * C<timer>
  143 
  144 Append run time for each test to output. Uses L<Time::HiRes> if available.
  145 
  146 =item * C<failures>
  147 
  148 Show test failures (this is a no-op if C<verbose> is selected).
  149 
  150 =item * C<comments>
  151 
  152 Show test comments (this is a no-op if C<verbose> is selected).
  153 
  154 =item * C<quiet>
  155 
  156 Suppressing some test output (mostly failures while tests are running).
  157 
  158 =item * C<really_quiet>
  159 
  160 Suppressing everything but the tests summary.
  161 
  162 =item * C<silent>
  163 
  164 Suppressing all output.
  165 
  166 =item * C<errors>
  167 
  168 If parse errors are found in the TAP output, a note of this will be made
  169 in the summary report.  To see all of the parse errors, set this argument to
  170 true:
  171 
  172   errors => 1
  173 
  174 =item * C<directives>
  175 
  176 If set to a true value, only test results with directives will be displayed.
  177 This overrides other settings such as C<verbose>, C<failures>, or C<comments>.
  178 
  179 =item * C<stdout>
  180 
  181 A filehandle for catching standard output.
  182 
  183 =item * C<color>
  184 
  185 If defined specifies whether color output is desired. If C<color> is not
  186 defined it will default to color output if color support is available on
  187 the current platform and output is not being redirected.
  188 
  189 =item * C<jobs>
  190 
  191 The number of concurrent jobs this formatter will handle.
  192 
  193 =item * C<show_count>
  194 
  195 Boolean value.  If false, disables the C<X/Y> test count which shows up while
  196 tests are running.
  197 
  198 =back
  199 
  200 Any keys for which the value is C<undef> will be ignored.
  201 
  202 =cut
  203 
  204 # new supplied by TAP::Base
  205 
  206 =head3 C<prepare>
  207 
  208 Called by Test::Harness before any test output is generated. 
  209 
  210 This is an advisory and may not be called in the case where tests are
  211 being supplied to Test::Harness by an iterator.
  212 
  213 =cut
  214 
  215 sub prepare {
  216     my ( $self, @tests ) = @_;
  217 
  218     my $longest = 0;
  219 
  220     for my $test (@tests) {
  221         $longest = length $test if length $test > $longest;
  222     }
  223 
  224     $self->_longest($longest);
  225 }
  226 
  227 sub _format_now { strftime "[%H:%M:%S]", localtime }
  228 
  229 sub _format_name {
  230     my ( $self, $test ) = @_;
  231     my $name = $test;
  232     my $periods = '.' x ( $self->_longest + 2 - length $test );
  233     $periods = " $periods ";
  234 
  235     if ( $self->timer ) {
  236         my $stamp = $self->_format_now();
  237         return "$stamp $name$periods";
  238     }
  239     else {
  240         return "$name$periods";
  241     }
  242 
  243 }
  244 
  245 =head3 C<open_test>
  246 
  247 Called to create a new test session. A test session looks like this:
  248 
  249     my $session = $formatter->open_test( $test, $parser );
  250     while ( defined( my $result = $parser->next ) ) {
  251         $session->result($result);
  252         exit 1 if $result->is_bailout;
  253     }
  254     $session->close_test;
  255 
  256 =cut
  257 
  258 sub open_test {
  259     die "Unimplemented.";
  260 }
  261 
  262 sub _output_success {
  263     my ( $self, $msg ) = @_;
  264     $self->_output($msg);
  265 }
  266 
  267 =head3 C<summary>
  268 
  269   $harness->summary( $aggregate );
  270 
  271 C<summary> prints the summary report after all tests are run. The first
  272 argument is an aggregate to summarise. An optional second argument may
  273 be set to a true value to indicate that the summary is being output as a
  274 result of an interrupted test run.
  275 
  276 =cut
  277 
  278 sub summary {
  279     my ( $self, $aggregate, $interrupted ) = @_;
  280 
  281     return if $self->silent;
  282 
  283     my @t     = $aggregate->descriptions;
  284     my $tests = \@t;
  285 
  286     my $runtime = $aggregate->elapsed_timestr;
  287 
  288     my $total  = $aggregate->total;
  289     my $passed = $aggregate->passed;
  290 
  291     if ( $self->timer ) {
  292         $self->_output( $self->_format_now(), "\n" );
  293     }
  294 
  295     $self->_failure_output("Test run interrupted!\n")
  296       if $interrupted;
  297 
  298     # TODO: Check this condition still works when all subtests pass but
  299     # the exit status is nonzero
  300 
  301     if ( $aggregate->all_passed ) {
  302         $self->_output_success("All tests successful.\n");
  303     }
  304 
  305     # ~TODO option where $aggregate->skipped generates reports
  306     if ( $total != $passed or $aggregate->has_problems ) {
  307         $self->_output("\nTest Summary Report");
  308         $self->_output("\n-------------------\n");
  309         for my $test (@$tests) {
  310             $self->_printed_summary_header(0);
  311             my ($parser) = $aggregate->parsers($test);
  312             $self->_output_summary_failure(
  313                 'failed',
  314                 [ '  Failed test:  ', '  Failed tests:  ' ],
  315                 $test, $parser
  316             );
  317             $self->_output_summary_failure(
  318                 'todo_passed',
  319                 "  TODO passed:   ", $test, $parser
  320             );
  321 
  322             # ~TODO this cannot be the default
  323             #$self->_output_summary_failure( 'skipped', "  Tests skipped: " );
  324 
  325             if ( my $exit = $parser->exit ) {
  326                 $self->_summary_test_header( $test, $parser );
  327                 $self->_failure_output("  Non-zero exit status: $exit\n");
  328             }
  329             elsif ( my $wait = $parser->wait ) {
  330                 $self->_summary_test_header( $test, $parser );
  331                 $self->_failure_output("  Non-zero wait status: $wait\n");
  332             }
  333 
  334             if ( my @errors = $parser->parse_errors ) {
  335                 my $explain;
  336                 if ( @errors > $MAX_ERRORS && !$self->errors ) {
  337                     $explain
  338                       = "Displayed the first $MAX_ERRORS of "
  339                       . scalar(@errors)
  340                       . " TAP syntax errors.\n"
  341                       . "Re-run prove with the -p option to see them all.\n";
  342                     splice @errors, $MAX_ERRORS;
  343                 }
  344                 $self->_summary_test_header( $test, $parser );
  345                 $self->_failure_output(
  346                     sprintf "  Parse errors: %s\n",
  347                     shift @errors
  348                 );
  349                 for my $error (@errors) {
  350                     my $spaces = ' ' x 16;
  351                     $self->_failure_output("$spaces$error\n");
  352                 }
  353                 $self->_failure_output($explain) if $explain;
  354             }
  355         }
  356     }
  357     my $files = @$tests;
  358     $self->_output("Files=$files, Tests=$total, $runtime\n");
  359     my $status = $aggregate->get_status;
  360     $self->_output("Result: $status\n");
  361 }
  362 
  363 sub _output_summary_failure {
  364     my ( $self, $method, $name, $test, $parser ) = @_;
  365 
  366     # ugly hack.  Must rethink this :(
  367     my $output = $method eq 'failed' ? '_failure_output' : '_output';
  368 
  369     if ( my @r = $parser->$method() ) {
  370         $self->_summary_test_header( $test, $parser );
  371         my ( $singular, $plural )
  372           = 'ARRAY' eq ref $name ? @$name : ( $name, $name );
  373         $self->$output( @r == 1 ? $singular : $plural );
  374         my @results = $self->_balanced_range( 40, @r );
  375         $self->$output( sprintf "%s\n" => shift @results );
  376         my $spaces = ' ' x 16;
  377         while (@results) {
  378             $self->$output( sprintf "$spaces%s\n" => shift @results );
  379         }
  380     }
  381 }
  382 
  383 sub _summary_test_header {
  384     my ( $self, $test, $parser ) = @_;
  385     return if $self->_printed_summary_header;
  386     my $spaces = ' ' x ( $self->_longest - length $test );
  387     $spaces = ' ' unless $spaces;
  388     my $output = $self->_get_output_method($parser);
  389     my $wait   = $parser->wait;
  390     defined $wait or $wait = '(none)';
  391     $self->$output(
  392         sprintf "$test$spaces(Wstat: %s Tests: %d Failed: %d)\n",
  393         $wait, $parser->tests_run, scalar $parser->failed
  394     );
  395     $self->_printed_summary_header(1);
  396 }
  397 
  398 sub _output {
  399     my $self = shift;
  400 
  401     print { $self->stdout } @_;
  402 }
  403 
  404 sub _failure_output {
  405     my $self = shift;
  406 
  407     $self->_output(@_);
  408 }
  409 
  410 sub _balanced_range {
  411     my ( $self, $limit, @range ) = @_;
  412     @range = $self->_range(@range);
  413     my $line = "";
  414     my @lines;
  415     my $curr = 0;
  416     while (@range) {
  417         if ( $curr < $limit ) {
  418             my $range = ( shift @range ) . ", ";
  419             $line .= $range;
  420             $curr += length $range;
  421         }
  422         elsif (@range) {
  423             $line =~ s/, $//;
  424             push @lines => $line;
  425             $line = '';
  426             $curr = 0;
  427         }
  428     }
  429     if ($line) {
  430         $line =~ s/, $//;
  431         push @lines => $line;
  432     }
  433     return @lines;
  434 }
  435 
  436 sub _range {
  437     my ( $self, @numbers ) = @_;
  438 
  439     # shouldn't be needed, but subclasses might call this
  440     @numbers = sort { $a <=> $b } @numbers;
  441     my ( $min, @range );
  442 
  443     for my $i ( 0 .. $#numbers ) {
  444         my $num  = $numbers[$i];
  445         my $next = $numbers[ $i + 1 ];
  446         if ( defined $next && $next == $num + 1 ) {
  447             if ( !defined $min ) {
  448                 $min = $num;
  449             }
  450         }
  451         elsif ( defined $min ) {
  452             push @range => "$min-$num";
  453             undef $min;
  454         }
  455         else {
  456             push @range => $num;
  457         }
  458     }
  459     return @range;
  460 }
  461 
  462 sub _get_output_method {
  463     my ( $self, $parser ) = @_;
  464     return $parser->has_problems ? '_failure_output' : '_output';
  465 }
  466 
  467 1;