File manager

File manager - Edit - /home/c14075/dragmet-ural.ru/www/Formatter.tar

Back
Base.pm��0000644��00000027136�15142416107�0005766 0��ustar�00��package TAP::Formatter::Base; use strict; use warnings; use base 'TAP::Base'; use POSIX qw(strftime); my $MAX_ERRORS = 5; my %VALIDATION_FOR; BEGIN { %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 $self->_is_filehandle($ref); return $ref; }, ); sub _is_filehandle { my ( $self, $ref ) = @_; return 0 if !defined $ref; return 1 if ref $ref eq 'GLOB'; # lexical filehandle return 1 if !ref $ref && ref \$ref eq 'GLOB'; # bare glob like STDOUT return 1 if eval { $ref->can('print') }; return 0; } my @getter_setters = qw( _longest _printed_summary_header _colorizer ); __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR ); } =head1 NAME TAP::Formatter::Base - Base class for harness output delegates =head1 VERSION Version 3.42 =cut our $VERSION = '3.42'; =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; for 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 first argument is an aggregate to summarise. An optional second argument may be set to a true value to indicate that the summary is being output as a result of an interrupted test run. =cut sub summary { my ( $self, $aggregate, $interrupted ) = @_; 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" ); } $self->_failure_output("Test run interrupted!\n") if $interrupted; # 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"); for 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 ); for 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); my $wait = $parser->wait; defined $wait or $wait = '(none)'; $self->$output( sprintf "$test$spaces(Wstat: %s Tests: %d Failed: %d)\n", $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 ); for 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; ��Session.pm��0000644��00000011574�15142416107�0006536 0��ustar�00��package TAP::Formatter::Session; use strict; use warnings; use base 'TAP::Base'; my @ACCESSOR; BEGIN { @ACCESSOR = qw( name formatter parser show_count ); for my $method (@ACCESSOR) { no strict 'refs'; $method = sub { shift->{$method} }; } } =head1 NAME TAP::Formatter::Session - Abstract base class for harness output delegate =head1 VERSION Version 3.42 =cut our $VERSION = '3.42'; =head1 METHODS =head2 Class Methods =head3 C<new> my %args = ( formatter => $self, ) my $harness = TAP::Formatter::Console::Session->new( \%args ); The constructor returns a new C<TAP::Formatter::Console::Session> object. =over 4 =item C<formatter> =item * C<parser> =item * C<name> =item * C<show_count> =back =cut sub _initialize { my ( $self, $arg_for ) = @_; $arg_for \|\|= {}; $self->SUPER::_initialize($arg_for); my %arg_for = %$arg_for; # force a shallow copy for my $name (@ACCESSOR) { $self->{$name} = delete $arg_for{$name}; } if ( !defined $self->show_count ) { $self->{show_count} = 1; # defaults to true } if ( $self->show_count ) { # but may be a damned lie! $self->{show_count} = $self->_should_show_count; } if ( my @props = sort keys %arg_for ) { $self->_croak( "Unknown arguments to " . __PACKAGE__ . "::new (@props)" ); } return $self; } =head3 C<header> Output test preamble =head3 C<result> Called by the harness for each line of TAP it receives. =head3 C<close_test> Called to close a test session. =head3 C<clear_for_close> Called by C<close_test> to clear the line showing test progress, or the parallel test ruler, prior to printing the final test result. =head3 C<time_report> Return a formatted string about the elapsed (wall-clock) time and about the consumed CPU time. =cut sub header { } sub result { } sub close_test { } sub clear_for_close { } sub _should_show_count { my $self = shift; return !$self->formatter->verbose && -t $self->formatter->stdout && !$ENV{HARNESS_NOTTY}; } sub _format_for_output { my ( $self, $result ) = @_; return $self->formatter->normalize ? $result->as_string : $result->raw; } sub _output_test_failure { my ( $self, $parser ) = @_; my $formatter = $self->formatter; return if $formatter->really_quiet; my $tests_run = $parser->tests_run; my $tests_planned = $parser->tests_planned; my $total = defined $tests_planned ? $tests_planned : $tests_run; my $passed = $parser->passed; # The total number of fails includes any tests that were planned but # didn't run my $failed = $parser->failed + $total - $tests_run; my $exit = $parser->exit; if ( my $exit = $parser->exit ) { my $wstat = $parser->wait; my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat ); $formatter->_failure_output("Dubious, test returned $status\n"); } if ( $failed == 0 ) { $formatter->_failure_output( $total ? "All $total subtests passed " : 'No subtests run ' ); } else { $formatter->_failure_output("Failed $failed/$total subtests "); if ( !$total ) { $formatter->_failure_output("\nNo tests run!"); } } if ( my $skipped = $parser->skipped ) { $passed -= $skipped; my $test = 'subtest' . ( $skipped != 1 ? 's' : '' ); $formatter->_output( "\n\t(less $skipped skipped $test: $passed okay)"); } if ( my $failed = $parser->todo_passed ) { my $test = $failed > 1 ? 'tests' : 'test'; $formatter->_output( "\n\t($failed TODO $test unexpectedly succeeded)"); } $formatter->_output("\n"); } sub _make_ok_line { my ( $self, $suffix ) = @_; return "ok$suffix\n"; } sub time_report { my ( $self, $formatter, $parser ) = @_; my @time_report; if ( $formatter->timer ) { my $start_time = $parser->start_time; my $end_time = $parser->end_time; if ( defined $start_time and defined $end_time ) { my $elapsed = $end_time - $start_time; push @time_report, $self->time_is_hires ? sprintf( ' %8d ms', $elapsed * 1000 ) : sprintf( ' %8s s', $elapsed \|\| '<1' ); } my $start_times = $parser->start_times(); my $end_times = $parser->end_times(); my $usr = $end_times->[0] - $start_times->[0]; my $sys = $end_times->[1] - $start_times->[1]; my $cusr = $end_times->[2] - $start_times->[2]; my $csys = $end_times->[3] - $start_times->[3]; push @time_report, sprintf('(%5.2f usr %5.2f sys + %5.2f cusr %5.2f csys = %5.2f CPU)', $usr, $sys, $cusr, $csys, $usr + $sys + $cusr + $csys); } return "@time_report"; } 1; ��File/Session.pm��0000644��00000004251�15142416107�0007407 0��ustar�00��package TAP::Formatter::File::Session; use strict; use warnings; use base 'TAP::Formatter::Session'; =head1 NAME TAP::Formatter::File::Session - Harness output delegate for file output =head1 VERSION Version 3.42 =cut our $VERSION = '3.42'; =head1 DESCRIPTION This provides file orientated output formatting for L<TAP::Harness>. It is particularly important when running with parallel tests, as it ensures that test results are not interleaved, even when run verbosely. =cut =head1 METHODS =head2 result Stores results for later output, all together. =cut sub result { my $self = shift; my $result = shift; my $parser = $self->parser; my $formatter = $self->formatter; if ( $result->is_bailout ) { $formatter->_failure_output( "Bailout called. Further testing stopped: " . $result->explanation . "\n" ); return; } if (!$formatter->quiet && ( $formatter->verbose \|\| ( $result->is_test && $formatter->failures && !$result->is_ok ) \|\| ( $formatter->comments && $result->is_comment ) \|\| ( $result->has_directive && $formatter->directives ) ) ) { $self->{results} .= $self->_format_for_output($result) . "\n"; } } =head2 close_test When the test file finishes, outputs the summary, together. =cut sub close_test { my $self = shift; # Avoid circular references $self->parser(undef); my $parser = $self->parser; my $formatter = $self->formatter; my $pretty = $formatter->_format_name( $self->name ); return if $formatter->really_quiet; if ( my $skip_all = $parser->skip_all ) { $formatter->_output( $pretty . "skipped: $skip_all\n" ); } elsif ( $parser->has_problems ) { $formatter->_output( $pretty . ( $self->{results} ? "\n" . $self->{results} : "\n" ) ); $self->_output_test_failure($parser); } else { my $time_report = $self->time_report($formatter, $parser); $formatter->_output( $pretty . ( $self->{results} ? "\n" . $self->{results} : "" ) . $self->_make_ok_line($time_report) ); } } 1; ��Console.pm��0000644��00000003713�15142416107�0006511 0��ustar�00��package TAP::Formatter::Console; use strict; use warnings; use base 'TAP::Formatter::Base'; use POSIX qw(strftime); =head1 NAME TAP::Formatter::Console - Harness output delegate for default console output =head1 VERSION Version 3.42 =cut our $VERSION = '3.42'; =head1 DESCRIPTION This provides console orientated output formatting for TAP::Harness. =head1 SYNOPSIS use TAP::Formatter::Console; my $harness = TAP::Formatter::Console->new( \%args ); =head2 C<< open_test >> See L<TAP::Formatter::Base> =cut sub open_test { my ( $self, $test, $parser ) = @_; my $class = $self->jobs > 1 ? 'TAP::Formatter::Console::ParallelSession' : 'TAP::Formatter::Console::Session'; eval "require $class"; $self->_croak($@) if $@; my $session = $class->new( { name => $test, formatter => $self, parser => $parser, show_count => $self->show_count, } ); $session->header; return $session; } # Use _colorizer delegate to set output color. NOP if we have no delegate sub _set_colors { my ( $self, @colors ) = @_; if ( my $colorizer = $self->_colorizer ) { my $output_func = $self->{_output_func} \|\|= sub { $self->_output(@_); }; $colorizer->set_color( $output_func, $_ ) for @colors; } } sub _failure_color { my ($self) = @_; return $ENV{'HARNESS_SUMMARY_COLOR_FAIL'} \|\| 'red'; } sub _success_color { my ($self) = @_; return $ENV{'HARNESS_SUMMARY_COLOR_SUCCESS'} \|\| 'green'; } sub _output_success { my ( $self, $msg ) = @_; $self->_set_colors( $self->_success_color() ); $self->_output($msg); $self->_set_colors('reset'); } sub _failure_output { my $self = shift; $self->_set_colors( $self->_failure_color() ); my $out = join '', @_; my $has_newline = chomp $out; $self->_output($out); $self->_set_colors('reset'); $self->_output($/) if $has_newline; } 1; ��File.pm��0000644��00000001522�15142416107�0005762 0��ustar�00��package TAP::Formatter::File; use strict; use warnings; use TAP::Formatter::File::Session; use POSIX qw(strftime); use base 'TAP::Formatter::Base'; =head1 NAME TAP::Formatter::File - Harness output delegate for file output =head1 VERSION Version 3.42 =cut our $VERSION = '3.42'; =head1 DESCRIPTION This provides file orientated output formatting for TAP::Harness. =head1 SYNOPSIS use TAP::Formatter::File; my $harness = TAP::Formatter::File->new( \%args ); =head2 C<< open_test >> See L<TAP::Formatter::Base> =cut sub open_test { my ( $self, $test, $parser ) = @_; my $session = TAP::Formatter::File::Session->new( { name => $test, formatter => $self, parser => $parser, } ); $session->header; return $session; } sub _should_show_count { return 0; } 1; ��Console/Session.pm��0000644��00000012627�15142416107�0010140 0��ustar�00��package TAP::Formatter::Console::Session; use strict; use warnings; use base 'TAP::Formatter::Session'; my @ACCESSOR; BEGIN { my @CLOSURE_BINDING = qw( header result clear_for_close close_test ); for my $method (@CLOSURE_BINDING) { no strict 'refs'; $method = sub { my $self = shift; return ( $self->{_closures} \|\|= $self->_closures )->{$method} ->(@_); }; } } =head1 NAME TAP::Formatter::Console::Session - Harness output delegate for default console output =head1 VERSION Version 3.42 =cut our $VERSION = '3.42'; =head1 DESCRIPTION This provides console orientated output formatting for TAP::Harness. =cut sub _get_output_result { my $self = shift; my @color_map = ( { test => sub { $_->is_test && !$_->is_ok }, colors => ['red'], }, { test => sub { $_->is_test && $_->has_skip }, colors => [ 'white', 'on_blue' ], }, { test => sub { $_->is_test && $_->has_todo }, colors => ['yellow'], }, ); my $formatter = $self->formatter; my $parser = $self->parser; return $formatter->_colorizer ? sub { my $result = shift; for my $col (@color_map) { local $_ = $result; if ( $col->{test}->() ) { $formatter->_set_colors( @{ $col->{colors} } ); last; } } $formatter->_output( $self->_format_for_output($result) ); $formatter->_set_colors('reset'); } : sub { $formatter->_output( $self->_format_for_output(shift) ); }; } sub _closures { my $self = shift; my $parser = $self->parser; my $formatter = $self->formatter; my $pretty = $formatter->_format_name( $self->name ); my $show_count = $self->show_count; my $really_quiet = $formatter->really_quiet; my $quiet = $formatter->quiet; my $verbose = $formatter->verbose; my $directives = $formatter->directives; my $failures = $formatter->failures; my $comments = $formatter->comments; my $output_result = $self->_get_output_result; my $output = '_output'; my $plan = ''; my $newline_printed = 0; my $last_status_printed = 0; return { header => sub { $formatter->_output($pretty) unless $really_quiet; }, result => sub { my $result = shift; if ( $result->is_bailout ) { $formatter->_failure_output( "Bailout called. Further testing stopped: " . $result->explanation . "\n" ); } return if $really_quiet; my $is_test = $result->is_test; # These are used in close_test - but only if $really_quiet # is false - so it's safe to only set them here unless that # relationship changes. if ( !$plan ) { my $planned = $parser->tests_planned \|\| '?'; $plan = "/$planned "; } $output = $formatter->_get_output_method($parser); if ( $show_count and $is_test ) { my $number = $result->number; my $now = CORE::time; # Print status roughly once per second. # We will always get the first number as a side effect of # $last_status_printed starting with the value 0, which $now # will never be. (Unless someone sets their clock to 1970) if ( $last_status_printed != $now ) { $formatter->$output("\r$pretty$number$plan"); $last_status_printed = $now; } } if (!$quiet && ( $verbose \|\| ( $is_test && $failures && !$result->is_ok ) \|\| ( $comments && $result->is_comment ) \|\| ( $directives && $result->has_directive ) ) ) { unless ($newline_printed) { $formatter->_output("\n"); $newline_printed = 1; } $output_result->($result); $formatter->_output("\n"); } }, clear_for_close => sub { my $spaces = ' ' x length( '.' . $pretty . $plan . $parser->tests_run ); $formatter->$output("\r$spaces"); }, close_test => sub { if ( $show_count && !$really_quiet ) { $self->clear_for_close; $formatter->$output("\r$pretty"); } # Avoid circular references $self->parser(undef); $self->{_closures} = {}; return if $really_quiet; if ( my $skip_all = $parser->skip_all ) { $formatter->_output("skipped: $skip_all\n"); } elsif ( $parser->has_problems ) { $self->_output_test_failure($parser); } else { my $time_report = $self->time_report($formatter, $parser); $formatter->_output( $self->_make_ok_line($time_report) ); } }, }; } =head2 C<< clear_for_close >> =head2 C<< close_test >> =head2 C<< header >> =head2 C<< result >> =cut 1; ��Console/ParallelSession.pm��0000644��00000010127�15142416107�0011606 0��ustar�00��package TAP::Formatter::Console::ParallelSession; use strict; use warnings; use File::Spec; use File::Path; use Carp; use base 'TAP::Formatter::Console::Session'; use constant WIDTH => 72; # Because Eric says my %shared; sub _initialize { my ( $self, $arg_for ) = @_; $self->SUPER::_initialize($arg_for); my $formatter = $self->formatter; # Horrid bodge. This creates our shared context per harness. Maybe # TAP::Harness should give us this? my $context = $shared{$formatter} \|\|= $self->_create_shared_context; push @{ $context->{active} }, $self; return $self; } sub _create_shared_context { my $self = shift; return { active => [], tests => 0, fails => 0, }; } =head1 NAME TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output =head1 VERSION Version 3.42 =cut our $VERSION = '3.42'; =head1 DESCRIPTION This provides console orientated output formatting for L<TAP::Harness> when run with multiple L<TAP::Harness/jobs>. =head1 SYNOPSIS =cut =head1 METHODS =head2 Class Methods =head3 C<header> Output test preamble =cut sub header { } sub _clear_ruler { my $self = shift; $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" ); } my $now = 0; my $start; my $trailer = '... )==='; my $chop_length = WIDTH - length $trailer; sub _output_ruler { my ( $self, $refresh ) = @_; my $new_now = time; return if $new_now == $now and !$refresh; $now = $new_now; $start \|\|= $now; my $formatter = $self->formatter; return if $formatter->really_quiet; my $context = $shared{$formatter}; my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start; for my $active ( @{ $context->{active} } ) { my $parser = $active->parser; my $tests = $parser->tests_run; my $planned = $parser->tests_planned \|\| '?'; $ruler .= sprintf '%' . length($planned) . "d/$planned ", $tests; } chop $ruler; # Remove a trailing space $ruler .= ')==='; if ( length $ruler > WIDTH ) { $ruler =~ s/(.{$chop_length})./$1$trailer/o; } else { $ruler .= '=' x ( WIDTH - length($ruler) ); } $formatter->_output("\r$ruler"); } =head3 C<result> Called by the harness for each line of TAP it receives . =cut sub result { my ( $self, $result ) = @_; my $formatter = $self->formatter; # my $really_quiet = $formatter->really_quiet; # my $show_count = $self->_should_show_count; if ( $result->is_test ) { my $context = $shared{$formatter}; $context->{tests}++; my $active = $context->{active}; if ( @$active == 1 ) { # There is only one test, so use the serial output format. return $self->SUPER::result($result); } $self->_output_ruler( $self->parser->tests_run == 1 ); } elsif ( $result->is_bailout ) { $formatter->_failure_output( "Bailout called. Further testing stopped: " . $result->explanation . "\n" ); } } =head3 C<clear_for_close> =cut sub clear_for_close { my $self = shift; my $formatter = $self->formatter; return if $formatter->really_quiet; my $context = $shared{$formatter}; if ( @{ $context->{active} } == 1 ) { $self->SUPER::clear_for_close; } else { $self->_clear_ruler; } } =head3 C<close_test> =cut sub close_test { my $self = shift; my $name = $self->name; my $parser = $self->parser; my $formatter = $self->formatter; my $context = $shared{$formatter}; $self->SUPER::close_test; my $active = $context->{active}; my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active; die "Can't find myself" unless @pos; splice @$active, $pos[0], 1; if ( @$active > 1 ) { $self->_output_ruler(1); } elsif ( @$active == 1 ) { # Print out "test/name.t ...." $active->[0]->SUPER::header; } else { # $self->formatter->_output("\n"); delete $shared{$formatter}; } } 1; ��Color.pm��0000644��00000004421�15142416107�0006162 0��ustar�00��package TAP::Formatter::Color; use strict; use warnings; use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); use base 'TAP::Object'; my $NO_COLOR; BEGIN { $NO_COLOR = 0; eval 'require Term::ANSIColor'; if ($@) { $NO_COLOR = $@; }; if (IS_WIN32) { eval 'use Win32::Console::ANSI'; if ($@) { $NO_COLOR = $@; } }; if ($NO_COLOR) { set_color = sub { }; } else { set_color = sub { my ( $self, $output, $color ) = @_; $output->( Term::ANSIColor::color($color) ); }; } } =head1 NAME TAP::Formatter::Color - Run Perl test scripts with color =head1 VERSION Version 3.42 =cut our $VERSION = '3.42'; =head1 DESCRIPTION Note that this harness is I<experimental>. You may not like the colors I've chosen and I haven't yet provided an easy way to override them. This test harness is the same as L<TAP::Harness>, but test results are output in color. Passing tests are printed in green. Failing tests are in red. Skipped tests are blue on a white background and TODO tests are printed in white. If L<Term::ANSIColor> cannot be found (and L<Win32::Console::ANSI> if running under Windows) tests will be run without color. =head1 SYNOPSIS use TAP::Formatter::Color; my $harness = TAP::Formatter::Color->new( \%args ); $harness->runtests(@tests); =head1 METHODS =head2 Class Methods =head3 C<new> The constructor returns a new C<TAP::Formatter::Color> object. If L<Term::ANSIColor> is not installed, returns undef. =cut # new() implementation supplied by TAP::Object sub _initialize { my $self = shift; if ($NO_COLOR) { # shorten that message a bit ( my $error = $NO_COLOR ) =~ s/ in \@INC .//s; warn "Note: Cannot run tests in color: $error\n"; return; # abort object construction } return $self; } ############################################################################## =head3 C<can_color> Test::Formatter::Color->can_color() Returns a boolean indicating whether or not this module can actually generate colored output. This will be false if it could not load the modules needed for the current platform. =cut sub can_color { return !$NO_COLOR; } =head3 C<set_color> Set the output color. =cut 1; ��TAP.pm��0000644��00000032644�15144032212�0005531 0��ustar�00��package Test2::Formatter::TAP; use strict; use warnings; our $VERSION = '1.302175'; use Test2::Util qw/clone_io/; use Test2::Util::HashBase qw{ no_numbers handles _encoding _last_fh -made_assertion }; sub OUT_STD() { 0 } sub OUT_ERR() { 1 } BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) } my $supports_tables; sub supports_tables { if (!defined $supports_tables) { local $SIG{__DIE__} = 'DEFAULT'; local $@; $supports_tables = ($INC{'Term/Table.pm'} && $INC{'Term/Table/Util.pm'}) \|\| eval { require Term::Table; require Term::Table::Util; 1 } \|\| 0; } return $supports_tables; } sub _autoflush { my($fh) = pop; my $old_fh = select $fh; $\| = 1; select $old_fh; } _autoflush(\STDOUT); _autoflush(\STDERR); sub hide_buffered { 1 } sub init { my $self = shift; $self->{+HANDLES} \|\|= $self->_open_handles; if(my $enc = delete $self->{encoding}) { $self->encoding($enc); } } sub _open_handles { my $self = shift; require Test2::API; my $out = clone_io(Test2::API::test2_stdout()); my $err = clone_io(Test2::API::test2_stderr()); _autoflush($out); _autoflush($err); return [$out, $err]; } sub encoding { my $self = shift; if ($] ge "5.007003" and @_) { my ($enc) = @_; my $handles = $self->{+HANDLES}; # https://rt.perl.org/Public/Bug/Display.html?id=31923 # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in # order to avoid the thread segfault. if ($enc =~ m/^utf-?8$/i) { binmode($_, ":utf8") for @$handles; } else { binmode($_, ":encoding($enc)") for @$handles; } $self->{+_ENCODING} = $enc; } return $self->{+_ENCODING}; } if ($^C) { no warnings 'redefine'; write = sub {}; } sub write { my ($self, $e, $num, $f) = @_; # The most common case, a pass event with no amnesty and a normal name. return if $self->print_optimal_pass($e, $num); $f \|\|= $e->facet_data; $self->encoding($f->{control}->{encoding}) if $f->{control}->{encoding}; my @tap = $self->event_tap($f, $num) or return; $self->{+MADE_ASSERTION} = 1 if $f->{assert}; my $nesting = $f->{trace}->{nested} \|\| 0; my $handles = $self->{+HANDLES}; my $indent = ' ' x $nesting; # Local is expensive! Only do it if we really need to. local($\, $,) = (undef, '') if $\ \|\| $,; for my $set (@tap) { no warnings 'uninitialized'; my ($hid, $msg) = @$set; next unless $msg; my $io = $handles->[$hid] or next; print $io "\n" if $ENV{HARNESS_ACTIVE} && $hid == OUT_ERR && $self->{+_LAST_FH} != $io && $msg =~ m/^#\sFailed( $TODO$)? test /; $msg =~ s/^/$indent/mg if $nesting; print $io $msg; $self->{+_LAST_FH} = $io; } } sub print_optimal_pass { my ($self, $e, $num) = @_; my $type = ref($e); # Only optimal if this is a Pass or a passing Ok return unless $type eq 'Test2::Event::Pass' \|\| ($type eq 'Test2::Event::Ok' && $e->{pass}); # Amnesty requires further processing (todo is a form of amnesty) return if ($e->{amnesty} && @{$e->{amnesty}}) \|\| defined($e->{todo}); # A name with a newline or hash symbol needs extra processing return if defined($e->{name}) && (-1 != index($e->{name}, "\n") \|\| -1 != index($e->{name}, '#')); my $ok = 'ok'; $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; $ok .= defined($e->{name}) ? " - $e->{name}\n" : "\n"; if (my $nesting = $e->{trace}->{nested}) { my $indent = ' ' x $nesting; $ok = "$indent$ok"; } my $io = $self->{+HANDLES}->[OUT_STD]; local($\, $,) = (undef, '') if $\ \|\| $,; print $io $ok; $self->{+_LAST_FH} = $io; return 1; } sub event_tap { my ($self, $f, $num) = @_; my @tap; # If this IS the first event the plan should come first # (plan must be before or after assertions, not in the middle) push @tap => $self->plan_tap($f) if $f->{plan} && !$self->{+MADE_ASSERTION}; # The assertion is most important, if present. if ($f->{assert}) { push @tap => $self->assert_tap($f, $num); push @tap => $self->debug_tap($f, $num) unless $f->{assert}->{no_debug} \|\| $f->{assert}->{pass}; } # Almost as important as an assertion push @tap => $self->error_tap($f) if $f->{errors}; # Now lets see the diagnostics messages push @tap => $self->info_tap($f) if $f->{info}; # If this IS NOT the first event the plan should come last # (plan must be before or after assertions, not in the middle) push @tap => $self->plan_tap($f) if $self->{+MADE_ASSERTION} && $f->{plan}; # Bail out push @tap => $self->halt_tap($f) if $f->{control}->{halt}; return @tap if @tap; return @tap if $f->{control}->{halt}; return @tap if grep { $f->{$_} } qw/assert plan info errors/; # Use the summary as a fallback if nothing else is usable. return $self->summary_tap($f, $num); } sub error_tap { my $self = shift; my ($f) = @_; my $IO = ($f->{amnesty} && @{$f->{amnesty}}) ? OUT_STD : OUT_ERR; return map { my $details = $_->{details}; my $msg; if (ref($details)) { require Data::Dumper; my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); chomp($msg = $dumper->Dump); } else { chomp($msg = $details); $msg =~ s/^/# /; $msg =~ s/\n/\n# /g; } [$IO, "$msg\n"]; } @{$f->{errors}}; } sub plan_tap { my $self = shift; my ($f) = @_; my $plan = $f->{plan} or return; return if $plan->{none}; if ($plan->{skip}) { my $reason = $plan->{details} or return [OUT_STD, "1..0 # SKIP\n"]; chomp($reason); return [OUT_STD, '1..0 # SKIP ' . $reason . "\n"]; } return [OUT_STD, "1.." . $plan->{count} . "\n"]; } sub no_subtest_space { 0 } sub assert_tap { my $self = shift; my ($f, $num) = @_; my $assert = $f->{assert} or return; my $pass = $assert->{pass}; my $name = $assert->{details}; my $ok = $pass ? 'ok' : 'not ok'; $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; # The regex form is ~250ms, the index form is ~50ms my @extra; defined($name) && ( (index($name, "\n") != -1 && (($name, @extra) = split(/\n\r?/, $name, -1))), ((index($name, "#" ) != -1 \|\| substr($name, -1) eq '\\') && (($name =~ s\|\\\|\\\\\|g), ($name =~ s\|#\|\\#\|g))) ); my $extra_space = @extra ? ' ' x (length($ok) + 2) : ''; my $extra_indent = ''; my ($directives, $reason, $is_skip); if ($f->{amnesty}) { my %directives; for my $am (@{$f->{amnesty}}) { next if $am->{inherited}; my $tag = $am->{tag} or next; $is_skip = 1 if $tag eq 'skip'; $directives{$tag} \|\|= $am->{details}; } my %seen; # Sort so that TODO comes before skip even on systems where lc sorts # before uc, as other code depends on that ordering. my @order = grep { !$seen{$_}++ } sort { lc $b cmp lc $a } keys %directives; $directives = ' # ' . join ' & ' => @order; for my $tag ('skip', @order) { next unless defined($directives{$tag}) && length($directives{$tag}); $reason = $directives{$tag}; last; } } $ok .= " - $name" if defined $name && !($is_skip && !$name); my @subtap; if ($f->{parent} && $f->{parent}->{buffered}) { $ok .= ' {'; # In a verbose harness we indent the extra since they will appear # inside the subtest braces. This helps readability. In a non-verbose # harness we do not do this because it is less readable. if ($ENV{HARNESS_IS_VERBOSE} \|\| !$ENV{HARNESS_ACTIVE}) { $extra_indent = " "; $extra_space = ' '; } # Render the sub-events, we use our own counter for these. my $count = 0; @subtap = map { my $f2 = $_; # Bump the count for any event that should bump it. $count++ if $f2->{assert}; # This indents all output lines generated for the sub-events. # index 0 is the filehandle, index 1 is the message we want to indent. map { $_->[1] =~ s/^(.\S.)$/ $1/mg; $_ } $self->event_tap($f2, $count); } @{$f->{parent}->{children}}; push @subtap => [OUT_STD, "}\n"]; } if ($directives) { $directives = ' # TODO & SKIP' if $directives eq ' # TODO & skip'; $ok .= $directives; $ok .= " $reason" if defined($reason); } $extra_space = ' ' if $self->no_subtest_space; my @out = ([OUT_STD, "$ok\n"]); push @out => map {[OUT_STD, "${extra_indent}#${extra_space}$_\n"]} @extra if @extra; push @out => @subtap; return @out; } sub debug_tap { my ($self, $f, $num) = @_; # Figure out the debug info, this is typically the file name and line # number, but can also be a custom message. If no trace object is provided # then we have nothing useful to display. my $name = $f->{assert}->{details}; my $trace = $f->{trace}; my $debug = "[No trace info available]"; if ($trace->{details}) { $debug = $trace->{details}; } elsif ($trace->{frame}) { my ($pkg, $file, $line) = @{$trace->{frame}}; $debug = "at $file line $line." if $file && $line; } my $amnesty = $f->{amnesty} && @{$f->{amnesty}} ? ' (with amnesty)' : ''; # Create the initial diagnostics. If the test has a name we put the debug # info on a second line, this behavior is inherited from Test::Builder. my $msg = defined($name) ? qq[# Failed test${amnesty} '$name'\n# $debug\n] : qq[# Failed test${amnesty} $debug\n]; my $IO = $f->{amnesty} && @{$f->{amnesty}} ? OUT_STD : OUT_ERR; return [$IO, $msg]; } sub halt_tap { my ($self, $f) = @_; return if $f->{trace}->{nested} && !$f->{trace}->{buffered}; my $details = $f->{control}->{details}; return [OUT_STD, "Bail out!\n"] unless defined($details) && length($details); return [OUT_STD, "Bail out! $details\n"]; } sub info_tap { my ($self, $f) = @_; return map { my $details = $_->{details}; my $table = $_->{table}; my $IO = $_->{debug} && !($f->{amnesty} && @{$f->{amnesty}}) ? OUT_ERR : OUT_STD; my $msg; if ($table && $self->supports_tables) { $msg = join "\n" => map { "# $_" } Term::Table->new( header => $table->{header}, rows => $table->{rows}, collapse => $table->{collapse}, no_collapse => $table->{no_collapse}, sanitize => 1, mark_tail => 1, max_width => $self->calc_table_size($f), )->render(); } elsif (ref($details)) { require Data::Dumper; my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); chomp($msg = $dumper->Dump); } else { chomp($msg = $details); $msg =~ s/^/# /; $msg =~ s/\n/\n# /g; } [$IO, "$msg\n"]; } @{$f->{info}}; } sub summary_tap { my ($self, $f, $num) = @_; return if $f->{about}->{no_display}; my $summary = $f->{about}->{details} or return; chomp($summary); $summary =~ s/^/# /smg; return [OUT_STD, "$summary\n"]; } sub calc_table_size { my $self = shift; my ($f) = @_; my $term = Term::Table::Util::term_size(); my $nesting = 2 + (($f->{trace}->{nested} \|\| 0) 4); # 4 spaces per level, also '# ' prefix my $total = $term - $nesting; # Sane minimum width, any smaller and we are asking for pain return 50 if $total < 50; return $total; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Formatter::TAP - Standard TAP formatter =head1 DESCRIPTION This is what takes events and turns them into TAP. =head1 SYNOPSIS use Test2::Formatter::TAP; my $tap = Test2::Formatter::TAP->new(); # Switch to utf8 $tap->encoding('utf8'); $tap->write($event, $number); # Output an event =head1 METHODS =over 4 =item $bool = $tap->no_numbers =item $tap->set_no_numbers($bool) Use to turn numbers on and off. =item $arrayref = $tap->handles =item $tap->set_handles(\@handles); Can be used to get/set the filehandles. Indexes are identified by the C<OUT_STD> and C<OUT_ERR> constants. =item $encoding = $tap->encoding =item $tap->encoding($encoding) Get or set the encoding. By default no encoding is set, the original settings of STDOUT and STDERR are used. This directly modifies the stored filehandles, it does not create new ones. =item $tap->write($e, $num) Write an event to the console. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =item Kent Fredric E<lt>kentnl@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2019 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut ��

| ver. 1.4 | Github | . | PHP 7.4.33 | Generation time: 0.26 | proxy | phpinfo | Settings