diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm | 449 |
1 files changed, 449 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm new file mode 100644 index 00000000000..f2b54a9ba3e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm @@ -0,0 +1,449 @@ +package TAP::Formatter::Base; + +use strict; +use TAP::Base (); +use POSIX qw(strftime); + +use vars qw($VERSION @ISA); + +my $MAX_ERRORS = 5; +my %VALIDATION_FOR; + +BEGIN { + @ISA = qw(TAP::Base); + + %VALIDATION_FOR = ( + directives => sub { shift; shift }, + verbosity => sub { shift; shift }, + normalize => sub { shift; shift }, + timer => sub { shift; shift }, + failures => sub { shift; shift }, + comments => sub { shift; shift }, + errors => sub { shift; shift }, + color => sub { shift; shift }, + jobs => sub { shift; shift }, + show_count => sub { shift; shift }, + stdout => sub { + my ( $self, $ref ) = @_; + $self->_croak("option 'stdout' needs a filehandle") + unless ( ref $ref || '' ) eq 'GLOB' + or eval { $ref->can('print') }; + return $ref; + }, + ); + + my @getter_setters = qw( + _longest + _printed_summary_header + _colorizer + ); + + __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR ); +} + +=head1 NAME + +TAP::Formatter::Console - Harness output delegate for default console output + +=head1 VERSION + +Version 3.17 + +=cut + +$VERSION = '3.17'; + +=head1 DESCRIPTION + +This provides console orientated output formatting for TAP::Harness. + +=head1 SYNOPSIS + + use TAP::Formatter::Console; + my $harness = TAP::Formatter::Console->new( \%args ); + +=cut + +sub _initialize { + my ( $self, $arg_for ) = @_; + $arg_for ||= {}; + + $self->SUPER::_initialize($arg_for); + my %arg_for = %$arg_for; # force a shallow copy + + $self->verbosity(0); + + for my $name ( keys %VALIDATION_FOR ) { + my $property = delete $arg_for{$name}; + if ( defined $property ) { + my $validate = $VALIDATION_FOR{$name}; + $self->$name( $self->$validate($property) ); + } + } + + if ( my @props = keys %arg_for ) { + $self->_croak( + "Unknown arguments to " . __PACKAGE__ . "::new (@props)" ); + } + + $self->stdout( \*STDOUT ) unless $self->stdout; + + if ( $self->color ) { + require TAP::Formatter::Color; + $self->_colorizer( TAP::Formatter::Color->new ); + } + + return $self; +} + +sub verbose { shift->verbosity >= 1 } +sub quiet { shift->verbosity <= -1 } +sub really_quiet { shift->verbosity <= -2 } +sub silent { shift->verbosity <= -3 } + +=head1 METHODS + +=head2 Class Methods + +=head3 C<new> + + my %args = ( + verbose => 1, + ) + my $harness = TAP::Formatter::Console->new( \%args ); + +The constructor returns a new C<TAP::Formatter::Console> object. If +a L<TAP::Harness> is created with no C<formatter> a +C<TAP::Formatter::Console> is automatically created. If any of the +following options were given to TAP::Harness->new they well be passed to +this constructor which accepts an optional hashref whose allowed keys are: + +=over 4 + +=item * C<verbosity> + +Set the verbosity level. + +=item * C<verbose> + +Printing individual test results to STDOUT. + +=item * C<timer> + +Append run time for each test to output. Uses L<Time::HiRes> if available. + +=item * C<failures> + +Show test failures (this is a no-op if C<verbose> is selected). + +=item * C<comments> + +Show test comments (this is a no-op if C<verbose> is selected). + +=item * C<quiet> + +Suppressing some test output (mostly failures while tests are running). + +=item * C<really_quiet> + +Suppressing everything but the tests summary. + +=item * C<silent> + +Suppressing all output. + +=item * C<errors> + +If parse errors are found in the TAP output, a note of this will be made +in the summary report. To see all of the parse errors, set this argument to +true: + + errors => 1 + +=item * C<directives> + +If set to a true value, only test results with directives will be displayed. +This overrides other settings such as C<verbose>, C<failures>, or C<comments>. + +=item * C<stdout> + +A filehandle for catching standard output. + +=item * C<color> + +If defined specifies whether color output is desired. If C<color> is not +defined it will default to color output if color support is available on +the current platform and output is not being redirected. + +=item * C<jobs> + +The number of concurrent jobs this formatter will handle. + +=item * C<show_count> + +Boolean value. If false, disables the C<X/Y> test count which shows up while +tests are running. + +=back + +Any keys for which the value is C<undef> will be ignored. + +=cut + +# new supplied by TAP::Base + +=head3 C<prepare> + +Called by Test::Harness before any test output is generated. + +This is an advisory and may not be called in the case where tests are +being supplied to Test::Harness by an iterator. + +=cut + +sub prepare { + my ( $self, @tests ) = @_; + + my $longest = 0; + + foreach my $test (@tests) { + $longest = length $test if length $test > $longest; + } + + $self->_longest($longest); +} + +sub _format_now { strftime "[%H:%M:%S]", localtime } + +sub _format_name { + my ( $self, $test ) = @_; + my $name = $test; + my $periods = '.' x ( $self->_longest + 2 - length $test ); + $periods = " $periods "; + + if ( $self->timer ) { + my $stamp = $self->_format_now(); + return "$stamp $name$periods"; + } + else { + return "$name$periods"; + } + +} + +=head3 C<open_test> + +Called to create a new test session. A test session looks like this: + + my $session = $formatter->open_test( $test, $parser ); + while ( defined( my $result = $parser->next ) ) { + $session->result($result); + exit 1 if $result->is_bailout; + } + $session->close_test; + +=cut + +sub open_test { + die "Unimplemented."; +} + +sub _output_success { + my ( $self, $msg ) = @_; + $self->_output($msg); +} + +=head3 C<summary> + + $harness->summary( $aggregate ); + +C<summary> prints the summary report after all tests are run. The argument is +an aggregate. + +=cut + +sub summary { + my ( $self, $aggregate ) = @_; + + return if $self->silent; + + my @t = $aggregate->descriptions; + my $tests = \@t; + + my $runtime = $aggregate->elapsed_timestr; + + my $total = $aggregate->total; + my $passed = $aggregate->passed; + + if ( $self->timer ) { + $self->_output( $self->_format_now(), "\n" ); + } + + # TODO: Check this condition still works when all subtests pass but + # the exit status is nonzero + + if ( $aggregate->all_passed ) { + $self->_output_success("All tests successful.\n"); + } + + # ~TODO option where $aggregate->skipped generates reports + if ( $total != $passed or $aggregate->has_problems ) { + $self->_output("\nTest Summary Report"); + $self->_output("\n-------------------\n"); + foreach my $test (@$tests) { + $self->_printed_summary_header(0); + my ($parser) = $aggregate->parsers($test); + $self->_output_summary_failure( + 'failed', + [ ' Failed test: ', ' Failed tests: ' ], + $test, $parser + ); + $self->_output_summary_failure( + 'todo_passed', + " TODO passed: ", $test, $parser + ); + + # ~TODO this cannot be the default + #$self->_output_summary_failure( 'skipped', " Tests skipped: " ); + + if ( my $exit = $parser->exit ) { + $self->_summary_test_header( $test, $parser ); + $self->_failure_output(" Non-zero exit status: $exit\n"); + } + elsif ( my $wait = $parser->wait ) { + $self->_summary_test_header( $test, $parser ); + $self->_failure_output(" Non-zero wait status: $wait\n"); + } + + if ( my @errors = $parser->parse_errors ) { + my $explain; + if ( @errors > $MAX_ERRORS && !$self->errors ) { + $explain + = "Displayed the first $MAX_ERRORS of " + . scalar(@errors) + . " TAP syntax errors.\n" + . "Re-run prove with the -p option to see them all.\n"; + splice @errors, $MAX_ERRORS; + } + $self->_summary_test_header( $test, $parser ); + $self->_failure_output( + sprintf " Parse errors: %s\n", + shift @errors + ); + foreach my $error (@errors) { + my $spaces = ' ' x 16; + $self->_failure_output("$spaces$error\n"); + } + $self->_failure_output($explain) if $explain; + } + } + } + my $files = @$tests; + $self->_output("Files=$files, Tests=$total, $runtime\n"); + my $status = $aggregate->get_status; + $self->_output("Result: $status\n"); +} + +sub _output_summary_failure { + my ( $self, $method, $name, $test, $parser ) = @_; + + # ugly hack. Must rethink this :( + my $output = $method eq 'failed' ? '_failure_output' : '_output'; + + if ( my @r = $parser->$method() ) { + $self->_summary_test_header( $test, $parser ); + my ( $singular, $plural ) + = 'ARRAY' eq ref $name ? @$name : ( $name, $name ); + $self->$output( @r == 1 ? $singular : $plural ); + my @results = $self->_balanced_range( 40, @r ); + $self->$output( sprintf "%s\n" => shift @results ); + my $spaces = ' ' x 16; + while (@results) { + $self->$output( sprintf "$spaces%s\n" => shift @results ); + } + } +} + +sub _summary_test_header { + my ( $self, $test, $parser ) = @_; + return if $self->_printed_summary_header; + my $spaces = ' ' x ( $self->_longest - length $test ); + $spaces = ' ' unless $spaces; + my $output = $self->_get_output_method($parser); + $self->$output( + sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n", + $parser->wait, $parser->tests_run, scalar $parser->failed + ); + $self->_printed_summary_header(1); +} + +sub _output { + my $self = shift; + + print { $self->stdout } @_; +} + +sub _failure_output { + my $self = shift; + + $self->_output(@_); +} + +sub _balanced_range { + my ( $self, $limit, @range ) = @_; + @range = $self->_range(@range); + my $line = ""; + my @lines; + my $curr = 0; + while (@range) { + if ( $curr < $limit ) { + my $range = ( shift @range ) . ", "; + $line .= $range; + $curr += length $range; + } + elsif (@range) { + $line =~ s/, $//; + push @lines => $line; + $line = ''; + $curr = 0; + } + } + if ($line) { + $line =~ s/, $//; + push @lines => $line; + } + return @lines; +} + +sub _range { + my ( $self, @numbers ) = @_; + + # shouldn't be needed, but subclasses might call this + @numbers = sort { $a <=> $b } @numbers; + my ( $min, @range ); + + foreach my $i ( 0 .. $#numbers ) { + my $num = $numbers[$i]; + my $next = $numbers[ $i + 1 ]; + if ( defined $next && $next == $num + 1 ) { + if ( !defined $min ) { + $min = $num; + } + } + elsif ( defined $min ) { + push @range => "$min-$num"; + undef $min; + } + else { + push @range => $num; + } + } + return @range; +} + +sub _get_output_method { + my ( $self, $parser ) = @_; + return $parser->has_problems ? '_failure_output' : '_output'; +} + +1; |