From: Steve Hay Date: Fri, 6 Mar 2009 15:22:23 +0000 (+0000) Subject: Upgrade to Test-Harness-3.16 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bdaf8c65d37b1e4fb9dee9eed906961f41184db9;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Test-Harness-3.16 But keep Test/Harness -> Test-Harness changes from commit f715bbfb20b232d289d3eddf42aec434ddd9dd4c and do likewise in new files file.t and harness-bailout.t too. --- diff --git a/MANIFEST b/MANIFEST index 1ba1298..e02106e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1186,10 +1186,14 @@ ext/Test-Harness/lib/App/Prove/State.pm Gubbins for the prove utility ext/Test-Harness/lib/App/Prove/State/Result.pm Gubbins for the prove utility ext/Test-Harness/lib/App/Prove/State/Result/Test.pm Gubbins for the prove utility ext/Test-Harness/lib/TAP/Base.pm A parser for Test Anything Protocol +ext/Test-Harness/lib/TAP/Formatter/Base.pm A parser for Test Anything Protocol ext/Test-Harness/lib/TAP/Formatter/Color.pm A parser for Test Anything Protocol ext/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm A parser for Test Anything Protocol ext/Test-Harness/lib/TAP/Formatter/Console.pm A parser for Test Anything Protocol ext/Test-Harness/lib/TAP/Formatter/Console/Session.pm A parser for Test Anything Protocol +ext/Test-Harness/lib/TAP/Formatter/File.pm A parser for Test Anything Protocol +ext/Test-Harness/lib/TAP/Formatter/File/Session.pm A parser for Test Anything Protocol +ext/Test-Harness/lib/TAP/Formatter/Session.pm A parser for Test Anything Protocol ext/Test-Harness/lib/TAP/Harness.pm A parser for Test Anything Protocol ext/Test-Harness/lib/TAP/Object.pm A parser for Test Anything Protocol ext/Test-Harness/lib/TAP/Parser/Aggregator.pm A parser for Test Anything Protocol @@ -1239,12 +1243,15 @@ ext/Test-Harness/t/data/catme.1 Test data for Test::Harness ext/Test-Harness/t/data/proverc Test data for Test::Harness ext/Test-Harness/t/data/sample.yml Test data for Test::Harness ext/Test-Harness/t/errors.t Test::Harness test +ext/Test-Harness/t/file.t Test::Harness test ext/Test-Harness/t/glob-to-regexp.t Test::Harness test ext/Test-Harness/t/grammar.t Test::Harness test +ext/Test-Harness/t/harness-bailout.t Test::Harness test ext/Test-Harness/t/harness-subclass.t Test::Harness test ext/Test-Harness/t/harness.t Test::Harness test ext/Test-Harness/t/iterators.t Test::Harness test ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm Module for testing Test::Harness +ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm Module for testing Test::Harness ext/Test-Harness/t/lib/Dev/Null.pm Module for testing Test::Harness ext/Test-Harness/t/lib/EmptyParser.pm Module for testing Test::Harness ext/Test-Harness/t/lib/IO/c55Capture.pm Module for testing Test::Harness @@ -1266,6 +1273,7 @@ ext/Test-Harness/t/object.t Test::Harness test ext/Test-Harness/t/parser-config.t Test::Harness test ext/Test-Harness/t/parser-subclass.t Test::Harness test ext/Test-Harness/t/parse.t Test::Harness test +ext/Test-Harness/t/perl5lib.t Test::Harness test ext/Test-Harness/t/premature-bailout.t Test::Harness test ext/Test-Harness/t/process.t Test::Harness test ext/Test-Harness/t/proveenv.t Test::Harness test diff --git a/ext/Test-Harness/Changes b/ext/Test-Harness/Changes index 4ae9f1d..44c04bd 100644 --- a/ext/Test-Harness/Changes +++ b/ext/Test-Harness/Changes @@ -1,7 +1,26 @@ Revision history for Test-Harness - -3.14 +3.16 2009-02-19 + - Fix path splicing on platforms where the path separator + is not ':'. + - Fixes/skips for failing Win32 tests. + - Don't break with older CPAN::Reporter versions. + +3.15 2009-02-17 + - Refactor getter/setter generation into TAP::Object. + - The App::Prove::State::Result::Test now stores the parser object. + - After discussion with Andy, agreed to clean up the test output + somewhat. t/foo.....ok becomes t/foo.t ... ok + - Make Bail out! die instead of exiting. Dies with the same + message as 2.64 for (belated) backwards compatibility. + - Alex Vaniver's patch to refactor TAP::Formatter::Console into + a new class, TAP::Formatter::File and a common base class: + TAP::Formatter::Base. + - Fix a bug where PERL5LIB might be put in the wrong spot in @INC. + #40257 + - Steve Purkis implemented a plugin mechanism for App::Prove. + +3.14 2008-09-13 - Created a proper (ha!) API for prove state results and tests. - Added --count and --nocount options to prove to control X/Y display while running tests. diff --git a/ext/Test-Harness/bin/prove b/ext/Test-Harness/bin/prove index 01df160..cde1b9b 100644 --- a/ext/Test-Harness/bin/prove +++ b/ext/Test-Harness/bin/prove @@ -259,6 +259,32 @@ names of any directories found in C as -I switches. The net effect of this is that C is honoured even when prove is run in taint mode. +=head1 PLUGINS + +Plugins can be loaded using the C<< -PI >> syntax, eg: + + prove -PMyPlugin + +This will search for a module named C, or failing +that, C. If the plugin can't be found, C will complain & exit. + +You can pass arguments to your plugin by appending C<=arg1,arg2,etc> to the +plugin name: + + prove -PMyPlugin=fou,du,fafa + +Please check individual plugin documentation for more details. + +=head2 Available Plugins + +For an up-to-date list of plugins available, please check CPAN: + +L + +=head2 Writing Plugins + +Please see L. + =cut # vim:ts=4:sw=4:et:sta diff --git a/ext/Test-Harness/lib/App/Prove.pm b/ext/Test-Harness/lib/App/Prove.pm index 29d2f8f..bc665fa 100644 --- a/ext/Test-Harness/lib/App/Prove.pm +++ b/ext/Test-Harness/lib/App/Prove.pm @@ -11,19 +11,17 @@ use Getopt::Long; use App::Prove::State; use Carp; -@ISA = qw(TAP::Object); - =head1 NAME App::Prove - Implements the C command. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION @@ -53,21 +51,16 @@ use constant PLUGINS => 'App::Prove::Plugin'; my @ATTR; BEGIN { + @ISA = qw(TAP::Object); + @ATTR = qw( archive argv blib show_count color directives exec failures fork formatter harness includes modules plugins jobs lib merge parse quiet really_quiet recurse backwards shuffle taint_fail taint_warn timer verbose warnings_fail warnings_warn show_help show_man show_version - test_args state dry extension ignore_exit rules state_manager + state_class test_args state dry extension ignore_exit rules state_manager ); - for my $attr (@ATTR) { - no strict 'refs'; - *$attr = sub { - my $self = shift; - $self->{$attr} = shift if @_; - return $self->{$attr}; - }; - } + __PACKAGE__->mk_methods(@ATTR); } =head1 METHODS @@ -108,27 +101,22 @@ sub _initialize { while ( my ( $env, $attr ) = each %env_provides_default ) { $self->{$attr} = 1 if $ENV{$env}; } - $self->state_manager( - $self->state_class->new( { store => STATE_FILE } ) ); - + $self->state_class('App::Prove::State'); return $self; } =head3 C -Returns the name of the class used for maintaining state. This class should -either subclass from C or provide an identical interface. +Getter/setter for the name of the class used for maintaining state. This +class should either subclass from C or provide an identical +interface. =head3 C -Getter/setter for the an instane of the C. +Getter/setter for the instance of the C. =cut -sub state_class { - return 'App::Prove::State'; -} - =head3 C $prove->add_rc_file('myproj/.proverc'); @@ -400,19 +388,22 @@ sub _find_module { } sub _load_extension { - my ( $self, $class, @search ) = @_; + my ( $self, $name, @search ) = @_; my @args = (); - if ( $class =~ /^(.*?)=(.*)/ ) { - $class = $1; + if ( $name =~ /^(.*?)=(.*)/ ) { + $name = $1; @args = split( /,/, $2 ); } - if ( my $name = $self->_find_module( $class, @search ) ) { - $name->import(@args); + if ( my $class = $self->_find_module( $name, @search ) ) { + $class->import(@args); + if ( $class->can('load') ) { + $class->load( { app_prove => $self, args => [@args] } ); + } } else { - croak "Can't load module $class"; + croak "Can't load module $name"; } } @@ -437,6 +428,11 @@ command line tool consists of the following code: sub run { my $self = shift; + unless ( $self->state_manager ) { + $self->state_manager( + $self->state_class->new( { store => STATE_FILE } ) ); + } + if ( $self->show_help ) { $self->_help(1); } @@ -675,6 +671,8 @@ calling C. =item C +=item C + =item C =item C @@ -690,3 +688,88 @@ calling C. =item C =back + +=head1 PLUGINS + +C provides support for 3rd-party plugins. These are currently +loaded at run-time, I arguments have been parsed (so you can not +change the way arguments are processed, sorry), typically with the +C<< -PI >> switch, eg: + + prove -PMyPlugin + +This will search for a module named C, or failing +that, C. If the plugin can't be found, C will complain & exit. + +You can pass an argument to your plugin by appending an C<=> after the plugin +name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas: + + prove -PMyPlugin=foo,bar,baz + +These are passed in to your plugin's C class method (if it has one), +along with a reference to the C object that is invoking your plugin: + + sub load { + my ($class, $p) = @_; + + my @args = @{ $p->{args} }; + # @args will contain ( 'foo', 'bar', 'baz' ) + $p->{app_prove}->do_something; + ... + } + +Note that the user's arguments are also passed to your plugin's C +function as a list, eg: + + sub import { + my ($class, @args) = @_; + # @args will contain ( 'foo', 'bar', 'baz' ) + ... + } + +This is for backwards compatibility, and may be deprecated in the future. + +=head2 Sample Plugin + +Here's a sample plugin, for your reference: + + package App::Prove::Plugin::Foo; + + # Sample plugin, try running with: + # prove -PFoo=bar -r -j3 + # prove -PFoo -Q + # prove -PFoo=bar,My::Formatter + + use strict; + use warnings; + + sub load { + my ($class, $p) = @_; + my @args = @{ $p->{args} }; + my $app = $p->{app_prove}; + + print "loading plugin: $class, args: ", join(', ', @args ), "\n"; + + # turn on verbosity + $app->verbose( 1 ); + + # set the formatter? + $app->formatter( $args[1] ) if @args > 1; + + # print some of App::Prove's state: + for my $attr (qw( jobs quiet really_quiet recurse verbose )) { + my $val = $app->$attr; + $val = 'undef' unless defined( $val ); + print "$attr: $val\n"; + } + + return 1; + } + + 1; + +=head1 SEE ALSO + +L, L + +=cut diff --git a/ext/Test-Harness/lib/App/Prove/State.pm b/ext/Test-Harness/lib/App/Prove/State.pm index 2b284d2..6eef184 100644 --- a/ext/Test-Harness/lib/App/Prove/State.pm +++ b/ext/Test-Harness/lib/App/Prove/State.pm @@ -12,7 +12,10 @@ use TAP::Parser::YAMLish::Reader (); use TAP::Parser::YAMLish::Writer (); use TAP::Base; -@ISA = qw( TAP::Base ); +BEGIN { + @ISA = qw( TAP::Base ); + __PACKAGE__->mk_methods('result_class'); +} use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); use constant NEED_GLOB => IS_WIN32; @@ -23,11 +26,11 @@ App::Prove::State - State storage for the C command. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION @@ -48,6 +51,24 @@ and the operations that may be performed on it. =head3 C +Accepts a hashref with the following key/value pairs: + +=over 4 + +=item * C + +The filename of the data store holding the data that App::Prove::State reads. + +=item * C (optional) + +The test name extension. Defaults to C<.t>. + +=item * C (optional) + +The name of the C. Defaults to C. + +=back + =cut # override TAP::Base::new: @@ -56,17 +77,19 @@ sub new { my %args = %{ shift || {} }; my $self = bless { - _ => $class->result_class->new( - { tests => {}, - generation => 1, - } - ), select => [], seq => 1, store => delete $args{store}, - extension => delete $args{extension} || '.t', + extension => ( delete $args{extension} || '.t' ), + result_class => + ( delete $args{result_class} || 'App::Prove::State::Result' ), }, $class; + $self->{_} = $self->result_class->new( + { tests => {}, + generation => 1, + } + ); my $store = $self->{store}; $self->load($store) if defined $store && -f $store; @@ -76,16 +99,12 @@ sub new { =head2 C -Returns the name of the class used for tracking test results. This class -should either subclass from C or provide an +Getter/setter for the name of the class used for tracking test results. This +class should either subclass from C or provide an identical interface. =cut -sub result_class { - return 'App::Prove::State::Result'; -} - =head2 C Get or set the extension files must have in order to be considered @@ -107,7 +126,7 @@ Get the results of the last test run. Returns a C instance. sub results { my $self = shift; - $self->{_} || $self->result_class->new + $self->{_} || $self->result_class->new; } =head2 C @@ -118,8 +137,8 @@ Save the test results. Should be called after all tests have run. sub commit { my $self = shift; - if ( $self->{should_save} && defined( my $store = $self->{store} ) ) { - $self->save($store); + if ( $self->{should_save} ) { + $self->save; } } @@ -373,15 +392,6 @@ Store the results of a test. =cut -sub observe_test { - my ( $self, $test, $parser ) = @_; - $self->_record_test( - $test->[0], - scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ), - scalar( $parser->todo ), $parser->start_time, $parser->end_time, - ); -} - # Store: # last fail time # last pass time @@ -391,10 +401,18 @@ sub observe_test { # total failures # total passes # state generation +# parser + +sub observe_test { -sub _record_test { - my ( $self, $name, $fail, $todo, $start_time, $end_time ) = @_; - my $test = $self->results->test($name); + my ( $self, $test_info, $parser ) = @_; + my $name = $test_info->[0]; + my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ); + my $todo = scalar( $parser->todo ); + my $start_time = $parser->start_time; + my $end_time = $parser->end_time, + + my $test = $self->results->test($name); $test->sequence( $self->{seq}++ ); $test->generation( $self->results->generation ); @@ -404,6 +422,8 @@ sub _record_test { $test->num_todo($todo); $test->elapsed( $end_time - $start_time ); + $test->parser($parser); + if ($fail) { $test->total_failures( $test->total_failures + 1 ); $test->last_fail_time($end_time); @@ -421,13 +441,14 @@ Write the state to a file. =cut sub save { - my ( $self, $name ) = @_; + my ($self) = @_; + my $store = $self->{store} or return; $self->results->last_run_time( $self->get_time ); my $writer = TAP::Parser::YAMLish::Writer->new; local *FH; - open FH, ">$name" or croak "Can't write $name ($!)"; + open FH, ">$store" or croak "Can't write $store ($!)"; $writer->write( $self->results->raw, \*FH ); close FH; } diff --git a/ext/Test-Harness/lib/App/Prove/State/Result.pm b/ext/Test-Harness/lib/App/Prove/State/Result.pm index 37337ea..a087da4 100644 --- a/ext/Test-Harness/lib/App/Prove/State/Result.pm +++ b/ext/Test-Harness/lib/App/Prove/State/Result.pm @@ -14,11 +14,11 @@ App::Prove::State::Result - Individual test suite results. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION @@ -63,10 +63,11 @@ sub _initialize { my ( $self, $tests ) = @_; my %tests; while ( my ( $name, $test ) = each %$tests ) { - $tests{$name} = $self->test_class->new({ - %$test, - name => $name - }); + $tests{$name} = $self->test_class->new( + { %$test, + name => $name + } + ); } $self->tests( \%tests ); return $self; @@ -170,7 +171,7 @@ sub test { return $test; } else { - my $test = $self->test_class->new({name => $name}); + my $test = $self->test_class->new( { name => $name } ); $self->{tests}->{$name} = $test; return $test; } diff --git a/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm b/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm index 50e2096..4744086 100644 --- a/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm +++ b/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm @@ -10,11 +10,11 @@ App::Prove::State::Result::Test - Individual test results. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION @@ -42,6 +42,7 @@ my %methods = ( seq => { method => 'sequence', default => 1 }, total_passes => { method => 'total_passes', default => 0 }, total_failures => { method => 'total_failures', default => 0 }, + parser => { method => 'parser' }, ); while ( my ( $key, $description ) = each %methods ) { @@ -132,14 +133,20 @@ The number of times the test has passed. The number of times the test has failed. +=head3 C + +The underlying parser object. This is useful if you need the full +information for the test program. + =cut sub raw { my $self = shift; my %raw = %$self; - # this is backwards-compatibility hack and is not gauranteed. + # this is backwards-compatibility hack and is not guaranteed. delete $raw{name}; + delete $raw{parser}; return \%raw; } diff --git a/ext/Test-Harness/lib/TAP/Base.pm b/ext/Test-Harness/lib/TAP/Base.pm index 25d4ce2..762d93d 100644 --- a/ext/Test-Harness/lib/TAP/Base.pm +++ b/ext/Test-Harness/lib/TAP/Base.pm @@ -9,15 +9,16 @@ use TAP::Object; =head1 NAME -TAP::Base - Base class that provides common functionality to L and L +TAP::Base - Base class that provides common functionality to L +and L =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; my $GOT_TIME_HIRES; @@ -51,17 +52,8 @@ C provides callback management. =head2 Class Methods -=head3 C - =cut -sub new { - my ( $class, $arg_for ) = @_; - - my $self = bless {}, $class; - return $self->_initialize($arg_for); -} - sub _initialize { my ( $self, $arg_for, $ok_callback ) = @_; diff --git a/ext/Test-Harness/lib/TAP/Formatter/Base.pm b/ext/Test-Harness/lib/TAP/Formatter/Base.pm new file mode 100644 index 0000000..704cfad --- /dev/null +++ b/ext/Test-Harness/lib/TAP/Formatter/Base.pm @@ -0,0 +1,438 @@ +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 }, + timer => sub { shift; shift }, + failures => 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.16 + +=cut + +$VERSION = '3.16'; + +=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 + + my %args = ( + verbose => 1, + ) + my $harness = TAP::Formatter::Console->new( \%args ); + +The constructor returns a new C object. If +a L is created with no C a +C 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 + +Set the verbosity level. + +=item * C + +Printing individual test results to STDOUT. + +=item * C + +Append run time for each test to output. Uses L if available. + +=item * C + +Only show test failures (this is a no-op if C is selected). + +=item * C + +Suppressing some test output (mostly failures while tests are running). + +=item * C + +Suppressing everything but the tests summary. + +=item * C + +Suppressing all output. + +=item * C + +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 + +If set to a true value, only test results with directives will be displayed. +This overrides other settings such as C or C. + +=item * C + +A filehandle for catching standard output. + +=item * C + +If defined specifies whether color output is desired. If C 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 + +The number of concurrent jobs this formatter will handle. + +=item * C + +Boolean value. If false, disables the C test count which shows up while +tests are running. + +=back + +Any keys for which the value is C will be ignored. + +=cut + +# new supplied by TAP::Base + +=head3 C + +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 + +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."; +} + +=head3 C + + $harness->summary( $aggregate ); + +C 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("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; diff --git a/ext/Test-Harness/lib/TAP/Formatter/Color.pm b/ext/Test-Harness/lib/TAP/Formatter/Color.pm index 8558854..36a5b16 100644 --- a/ext/Test-Harness/lib/TAP/Formatter/Color.pm +++ b/ext/Test-Harness/lib/TAP/Formatter/Color.pm @@ -71,11 +71,11 @@ TAP::Formatter::Color - Run Perl test scripts with color =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION diff --git a/ext/Test-Harness/lib/TAP/Formatter/Console.pm b/ext/Test-Harness/lib/TAP/Formatter/Console.pm index beacf9f..71cad30 100644 --- a/ext/Test-Harness/lib/TAP/Formatter/Console.pm +++ b/ext/Test-Harness/lib/TAP/Formatter/Console.pm @@ -1,50 +1,12 @@ package TAP::Formatter::Console; use strict; -use TAP::Base (); +use TAP::Formatter::Base (); use POSIX qw(strftime); use vars qw($VERSION @ISA); -@ISA = qw(TAP::Base); - -my $MAX_ERRORS = 5; -my %VALIDATION_FOR; - -BEGIN { - %VALIDATION_FOR = ( - directives => sub { shift; shift }, - verbosity => sub { shift; shift }, - timer => sub { shift; shift }, - failures => 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 - ); - - for my $method ( @getter_setters, keys %VALIDATION_FOR ) { - no strict 'refs'; - *$method = sub { - my $self = shift; - return $self->{$method} unless @_; - $self->{$method} = shift; - }; - } -} +@ISA = qw(TAP::Formatter::Base); =head1 NAME @@ -52,11 +14,11 @@ TAP::Formatter::Console - Harness output delegate for default console output =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION @@ -67,180 +29,9 @@ This provides console orientated output formatting for TAP::Harness. 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 - - my %args = ( - verbose => 1, - ) - my $harness = TAP::Formatter::Console->new( \%args ); - -The constructor returns a new C object. If -a L is created with no C a -C 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 - -Set the verbosity level. - -=item * C - -Printing individual test results to STDOUT. - -=item * C - -Append run time for each test to output. Uses L if available. - -=item * C - -Only show test failures (this is a no-op if C is selected). - -=item * C - -Suppressing some test output (mostly failures while tests are running). - -=item * C - -Suppressing everything but the tests summary. - -=item * C - -Suppressing all output. - -=item * C - -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 - -If set to a true value, only test results with directives will be displayed. -This overrides other settings such as C or C. - -=item * C - -A filehandle for catching standard output. - -=item * C - -If defined specifies whether color output is desired. If C 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 - -The number of concurrent jobs this formatter will handle. - -=item * C - -Boolean value. If false, disables the C test count which shows up while -tests are running. - -=back - -Any keys for which the value is C will be ignored. - -=cut - -# new supplied by TAP::Base - -=head3 C - -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; +=head2 C<< open_test >> - 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 + 4 - length $test ); - - if ( $self->timer ) { - my $stamp = $self->_format_now(); - return "$stamp $name$periods"; - } - else { - return "$name$periods"; - } - -} - -=head3 C - -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; +See L =cut @@ -268,132 +59,6 @@ sub open_test { return $session; } -=head3 C - - $harness->summary( $aggregate ); - -C 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("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"); - } - - 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 } @_; -} - # Use _colorizer delegate to set output color. NOP if we have no delegate sub _set_colors { my ( $self, @colors ) = @_; @@ -416,61 +81,4 @@ sub _failure_output { if $has_newline; } -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; diff --git a/ext/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm b/ext/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm index eae6598..dcee635 100644 --- a/ext/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm +++ b/ext/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm @@ -42,11 +42,11 @@ TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION @@ -78,11 +78,11 @@ sub _clear_ruler { my $now = 0; my $start; -my $trailer = '... )==='; +my $trailer = '... )==='; my $chop_length = WIDTH - length $trailer; sub _output_ruler { - my ($self, $refresh) = @_; + my ( $self, $refresh ) = @_; my $new_now = time; return if $new_now == $now and !$refresh; $now = $new_now; @@ -94,23 +94,23 @@ sub _output_ruler { my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start; - foreach my $active ( @{$context->{active}} ) { - my $parser = $active->parser; - my $tests = $parser->tests_run; - my $planned = $parser->tests_planned || '?'; + foreach 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; + $ruler .= sprintf '%' . length($planned) . "d/$planned ", $tests; } - chop $ruler; # Remove a trailing space + chop $ruler; # Remove a trailing space $ruler .= ')==='; if ( length $ruler > WIDTH ) { - $ruler =~ s/(.{$chop_length}).*/$1$trailer/o; + $ruler =~ s/(.{$chop_length}).*/$1$trailer/o; } else { - $ruler .= '=' x ( WIDTH - length( $ruler ) ); + $ruler .= '=' x ( WIDTH - length($ruler) ); } - $formatter->_output( "\r$ruler"); + $formatter->_output("\r$ruler"); } =head3 C @@ -130,13 +130,14 @@ sub result { my $context = $shared{$formatter}; $context->{tests}++; - my $active = $context->{active}; - if ( @$active == 1 ) { + my $active = $context->{active}; + if ( @$active == 1 ) { + # There is only one test, so use the serial output format. - return $self->SUPER::result( $result ); + return $self->SUPER::result($result); } - $self->_output_ruler( $self->parser->tests_run == 1 ); + $self->_output_ruler( $self->parser->tests_run == 1 ); } elsif ( $result->is_bailout ) { $formatter->_failure_output( @@ -154,12 +155,12 @@ sub clear_for_close { my $self = shift; my $formatter = $self->formatter; return if $formatter->really_quiet; - my $context = $shared{$formatter}; + my $context = $shared{$formatter}; if ( @{ $context->{active} } == 1 ) { - $self->SUPER::clear_for_close; + $self->SUPER::clear_for_close; } else { - $self->_clear_ruler; + $self->_clear_ruler; } } @@ -183,14 +184,16 @@ sub close_test { die "Can't find myself" unless @pos; splice @$active, $pos[0], 1; - if (@$active > 1) { - $self->_output_ruler( 1 ); + if ( @$active > 1 ) { + $self->_output_ruler(1); } - elsif (@$active == 1) { + elsif ( @$active == 1 ) { + # Print out "test/name.t ...." $active->[0]->SUPER::header; } else { + # $self->formatter->_output("\n"); delete $shared{$formatter}; } diff --git a/ext/Test-Harness/lib/TAP/Formatter/Console/Session.pm b/ext/Test-Harness/lib/TAP/Formatter/Console/Session.pm index 074407b..129f388 100644 --- a/ext/Test-Harness/lib/TAP/Formatter/Console/Session.pm +++ b/ext/Test-Harness/lib/TAP/Formatter/Console/Session.pm @@ -1,23 +1,15 @@ package TAP::Formatter::Console::Session; use strict; -use TAP::Base; +use TAP::Formatter::Session; use vars qw($VERSION @ISA); -@ISA = qw(TAP::Base); +@ISA = qw(TAP::Formatter::Session); my @ACCESSOR; BEGIN { - - @ACCESSOR = qw( name formatter parser show_count ); - - for my $method (@ACCESSOR) { - no strict 'refs'; - *$method = sub { shift->{$method} }; - } - my @CLOSURE_BINDING = qw( header result clear_for_close close_test ); for my $method (@CLOSURE_BINDING) { @@ -36,89 +28,16 @@ TAP::Formatter::Console::Session - Harness output delegate for default console o =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION This provides console orientated output formatting for TAP::Harness. -=head1 SYNOPSIS - -=cut - -=head1 METHODS - -=head2 Class Methods - -=head3 C - - my %args = ( - formatter => $self, - ) - my $harness = TAP::Formatter::Console::Session->new( \%args ); - -The constructor returns a new C object. - -=over 4 - -=item * C - -=item * C - -=item * C - -=item * C - -=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 TAP::Harness::new (@props)"); - } - - return $self; -} - -=head3 C
- -Output test preamble - -=head3 C - -Called by the harness for each line of TAP it receives. - -=head3 C - -Called to close a test session. - -=head3 C - -Called by C to clear the line showing test progress, or the parallel -test ruler, prior to printing the final test result. - =cut sub _get_output_result { @@ -217,9 +136,9 @@ sub _closures { 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) + # 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; @@ -242,13 +161,13 @@ sub _closures { }, clear_for_close => sub { - my $spaces = ' ' x - length( '.' . $pretty . $plan . $parser->tests_run ); + my $spaces + = ' ' x length( '.' . $pretty . $plan . $parser->tests_run ); $formatter->$output("\r$spaces"); }, - + close_test => sub { - if ($show_count && !$really_quiet) { + if ( $show_count && !$really_quiet ) { $self->clear_for_close; $formatter->$output("\r$pretty"); } @@ -285,67 +204,14 @@ sub _closures { }; } -sub _should_show_count { +=head2 C<< clear_for_close >> - # we need this because if someone tries to redirect the output, it can get - # very garbled from the carriage returns (\r) in the count line. - return !shift->formatter->verbose && -t STDOUT; -} - -sub _output_test_failure { - my ( $self, $parser ) = @_; - my $formatter = $self->formatter; - return if $formatter->really_quiet; +=head2 C<< close_test >> - my $tests_run = $parser->tests_run; - my $tests_planned = $parser->tests_planned; +=head2 C<< header >> - my $total - = defined $tests_planned - ? $tests_planned - : $tests_run; +=head2 C<< result >> - 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"); -} +=cut 1; diff --git a/ext/Test-Harness/lib/TAP/Formatter/File.pm b/ext/Test-Harness/lib/TAP/Formatter/File.pm new file mode 100644 index 0000000..142fbc9 --- /dev/null +++ b/ext/Test-Harness/lib/TAP/Formatter/File.pm @@ -0,0 +1,58 @@ +package TAP::Formatter::File; + +use strict; +use TAP::Formatter::Base (); +use TAP::Formatter::File::Session; +use POSIX qw(strftime); + +use vars qw($VERSION @ISA); + +@ISA = qw(TAP::Formatter::Base); + +=head1 NAME + +TAP::Formatter::File - Harness output delegate for file output + +=head1 VERSION + +Version 3.16 + +=cut + +$VERSION = '3.16'; + +=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 + +=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; diff --git a/ext/Test-Harness/lib/TAP/Formatter/File/Session.pm b/ext/Test-Harness/lib/TAP/Formatter/File/Session.pm new file mode 100644 index 0000000..1448770 --- /dev/null +++ b/ext/Test-Harness/lib/TAP/Formatter/File/Session.pm @@ -0,0 +1,109 @@ +package TAP::Formatter::File::Session; + +use strict; +use TAP::Formatter::Session; + +use vars qw($VERSION @ISA); + +@ISA = qw(TAP::Formatter::Session); + +=head1 NAME + +TAP::Formatter::File::Session - Harness output delegate for file output + +=head1 VERSION + +Version 3.16 + +=cut + +$VERSION = '3.16'; + +=head1 DESCRIPTION + +This provides file orientated output formatting for L. +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 && !$formatter->failures ) + || ( $result->is_test && $formatter->failures && !$result->is_ok ) + || ( $result->has_directive && $formatter->directives ) ) + ) + { + $self->{results} .= $result->as_string . "\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 = ''; + 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; + $time_report + = $self->time_is_hires + ? sprintf( ' %8d ms', $elapsed * 1000 ) + : sprintf( ' %8s s', $elapsed || '<1' ); + } + } + + $formatter->_output( $pretty + . ( $self->{results} ? "\n" . $self->{results} : "" ) + . "ok$time_report\n" ); + } +} + +1; diff --git a/ext/Test-Harness/lib/TAP/Formatter/Session.pm b/ext/Test-Harness/lib/TAP/Formatter/Session.pm new file mode 100644 index 0000000..a68e2a0 --- /dev/null +++ b/ext/Test-Harness/lib/TAP/Formatter/Session.pm @@ -0,0 +1,175 @@ +package TAP::Formatter::Session; + +use strict; +use TAP::Base; + +use vars qw($VERSION @ISA); + +@ISA = qw(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.16 + +=cut + +$VERSION = '3.16'; + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my %args = ( + formatter => $self, + ) + my $harness = TAP::Formatter::Console::Session->new( \%args ); + +The constructor returns a new C object. + +=over 4 + +=item * C + +=item * C + +=item * C + +=item * C + +=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
+ +Output test preamble + +=head3 C + +Called by the harness for each line of TAP it receives. + +=head3 C + +Called to close a test session. + +=head3 C + +Called by C to clear the line showing test progress, or the parallel +test ruler, prior to printing the final test result. + +=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; +} + +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"); +} + +1; diff --git a/ext/Test-Harness/lib/TAP/Harness.pm b/ext/Test-Harness/lib/TAP/Harness.pm index 27961cc..1512969 100644 --- a/ext/Test-Harness/lib/TAP/Harness.pm +++ b/ext/Test-Harness/lib/TAP/Harness.pm @@ -19,11 +19,11 @@ TAP::Harness - Run test scripts with statistics =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; $ENV{HARNESS_ACTIVE} = 1; $ENV{HARNESS_VERSION} = $VERSION; @@ -226,7 +226,8 @@ L. =item * C The name of the class to use to format output. The default is -L. +L, or L if the output +isn't a TTY. =item * C @@ -347,6 +348,9 @@ Any keys for which the value is C will be ignored. $self->jobs(1) unless defined $self->jobs; + local $default_class{formatter_class} = 'TAP::Formatter::File' + unless -t ( $arg_for{stdout} || \*STDOUT ); + while ( my ( $attr, $class ) = each %default_class ) { $self->$attr( $self->$attr() || $class ); } @@ -462,7 +466,7 @@ sub _aggregate_forked { my ( $parser, $session ) = $self->make_parser($job); while ( defined( my $result = $parser->next ) ) { - exit 1 if $result->is_bailout; + $self->_bailout($result) if $result->is_bailout; } $self->finish_parser( $parser, $session ); @@ -485,6 +489,13 @@ sub _aggregate_forked { return; } +sub _bailout { + my ( $self, $result ) = @_; + my $explanation = $result->explanation; + die "FAILED--Further testing stopped" + . ( $explanation ? ": $explanation\n" : ".\n" ); +} + sub _aggregate_parallel { my ( $self, $aggregate, $scheduler ) = @_; @@ -509,7 +520,7 @@ sub _aggregate_parallel { my ( $session, $job ) = @$stash; if ( defined $result ) { $session->result($result); - exit 1 if $result->is_bailout; + $self->_bailout($result) if $result->is_bailout; } else { @@ -541,7 +552,7 @@ sub _aggregate_single { # Keep reading until input is exhausted in the hope # of allowing any pending diagnostics to show up. 1 while $parser->next; - exit 1; + $self->_bailout($result); } } @@ -635,23 +646,10 @@ sub aggregate_tests { sub _add_descriptions { my $self = shift; - # First transformation: turn scalars into single element arrays - my @tests = map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_; - - # Work out how many different extensions we have - my %ext; - for my $test (@tests) { - $ext{$1}++ if $test->[0] =~ /\.(\w+)$/; - } - - for my $test (@tests) { - if ( @$test == 1 ) { - $test->[1] = $test->[0]; - $test->[1] =~ s/\.\w+$// - if keys %ext <= 1; - } - } - return @tests; + # Turn unwrapped scalars into anonymous arrays and copy the name as + # the description for tests that have only a name. + return map { @$_ == 1 ? [ $_->[0], $_->[0] ] : $_ } + map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_; } =head3 C @@ -674,10 +672,9 @@ sub make_scheduler { =head3 C -Gets or sets the number of concurrent test runs the harness is handling. -For the default harness this value is always 1. A parallel harness such -as L will override this to return the number of -jobs it is handling. +Gets or sets the number of concurrent test runs the harness is +handling. By default, this value is 1 -- for parallel testing, this +should be set higher. =head3 C diff --git a/ext/Test-Harness/lib/TAP/Object.pm b/ext/Test-Harness/lib/TAP/Object.pm index bbc7bfd..b57d32e 100644 --- a/ext/Test-Harness/lib/TAP/Object.pm +++ b/ext/Test-Harness/lib/TAP/Object.pm @@ -9,11 +9,11 @@ TAP::Object - Base class that provides common functionality to all C mod =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS @@ -114,5 +114,26 @@ sub _construct { return $class->new(@args); } +=head3 C + +Create simple getter/setters. + + __PACKAGE__->mk_methods(@method_names); + +=cut + +sub mk_methods { + my ( $class, @methods ) = @_; + foreach my $method_name (@methods) { + my $method = "${class}::$method_name"; + no strict 'refs'; + *$method = sub { + my $self = shift; + $self->{$method_name} = shift if @_; + return $self->{$method_name}; + }; + } +} + 1; diff --git a/ext/Test-Harness/lib/TAP/Parser.pm b/ext/Test-Harness/lib/TAP/Parser.pm index c02f2ac..2393418 100644 --- a/ext/Test-Harness/lib/TAP/Parser.pm +++ b/ext/Test-Harness/lib/TAP/Parser.pm @@ -14,19 +14,17 @@ use TAP::Parser::IteratorFactory (); use Carp qw( confess ); -@ISA = qw(TAP::Base); - =head1 NAME TAP::Parser - Parse L output =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; my $DEFAULT_TAP_VERSION = 12; my $MAX_TAP_VERSION = 13; @@ -40,37 +38,31 @@ END { } BEGIN { # making accessors - foreach my $method ( + @ISA = qw(TAP::Base); + + __PACKAGE__->mk_methods( qw( - _stream - _spool - exec - exit - is_good_plan - plan - tests_planned - tests_run - wait - version - in_todo - start_time - end_time - skip_all - source_class - perl_source_class - grammar_class - iterator_factory_class - result_factory_class - ) - ) - { - no strict 'refs'; - *$method = sub { - my $self = shift; - return $self->{$method} unless @_; - $self->{$method} = shift; - }; - } + _stream + _spool + exec + exit + is_good_plan + plan + tests_planned + tests_run + wait + version + in_todo + start_time + end_time + skip_all + source_class + perl_source_class + grammar_class + iterator_factory_class + result_factory_class + ) + ); } # done making accessors =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/TAP/Parser/Aggregator.pm b/ext/Test-Harness/lib/TAP/Parser/Aggregator.pm index d6fad64..2adc6e5 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Aggregator.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Aggregator.pm @@ -14,11 +14,11 @@ TAP::Parser::Aggregator - Aggregate TAP::Parser results =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS @@ -71,7 +71,8 @@ BEGIN { # install summary methods wait exit ); - $SUMMARY_METHOD_FOR{total} = 'tests_run'; + $SUMMARY_METHOD_FOR{total} = 'tests_run'; + $SUMMARY_METHOD_FOR{planned} = 'tests_planned'; foreach my $method ( keys %SUMMARY_METHOD_FOR ) { next if 'total' eq $method; @@ -184,7 +185,8 @@ sub _get_parsers { =head3 C -Get an array of descriptions in the order in which they were added to the aggregator. +Get an array of descriptions in the order in which they were added to +the aggregator. =cut @@ -298,6 +300,8 @@ for an explanation of description. =item * passed +=item * planned + =item * skipped =item * todo @@ -367,7 +371,7 @@ Returns true if I of the parsers failed. This includes: =item * Failed tests -=item * Parse erros +=item * Parse errors =item * Bad exit or wait status diff --git a/ext/Test-Harness/lib/TAP/Parser/Grammar.pm b/ext/Test-Harness/lib/TAP/Parser/Grammar.pm index a644b07..7ea1d03 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Grammar.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Grammar.pm @@ -15,11 +15,11 @@ TAP::Parser::Grammar - A grammar for the Test Anything Protocol. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/TAP/Parser/Iterator.pm b/ext/Test-Harness/lib/TAP/Parser/Iterator.pm index d33a963..b66e2e1 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Iterator.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Iterator.pm @@ -13,11 +13,11 @@ TAP::Parser::Iterator - Internal base class for TAP::Parser Iterators =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/TAP/Parser/Iterator/Array.pm b/ext/Test-Harness/lib/TAP/Parser/Iterator/Array.pm index 4495bb8..9d7e2c2 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Iterator/Array.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Iterator/Array.pm @@ -13,11 +13,11 @@ TAP::Parser::Iterator::Array - Internal TAP::Parser array Iterator =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/TAP/Parser/Iterator/Process.pm b/ext/Test-Harness/lib/TAP/Parser/Iterator/Process.pm index cc9786c..027de0c 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Iterator/Process.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Iterator/Process.pm @@ -17,11 +17,11 @@ TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm b/ext/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm index e71dfc4..3ed2534 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm @@ -13,11 +13,11 @@ TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/TAP/Parser/IteratorFactory.pm b/ext/Test-Harness/lib/TAP/Parser/IteratorFactory.pm index 7aa4e4d..5186df1 100644 --- a/ext/Test-Harness/lib/TAP/Parser/IteratorFactory.pm +++ b/ext/Test-Harness/lib/TAP/Parser/IteratorFactory.pm @@ -16,11 +16,11 @@ TAP::Parser::IteratorFactory - Internal TAP::Parser Iterator =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/TAP/Parser/Multiplexer.pm b/ext/Test-Harness/lib/TAP/Parser/Multiplexer.pm index 2efeb30..94761bc 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Multiplexer.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Multiplexer.pm @@ -18,11 +18,11 @@ TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/TAP/Parser/Result.pm b/ext/Test-Harness/lib/TAP/Parser/Result.pm index 486c6ff..8e3497b 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Result.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Result.pm @@ -26,11 +26,11 @@ TAP::Parser::Result - Base class for TAP::Parser output objects =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS @@ -68,10 +68,10 @@ sub _initialize { my ( $self, $token ) = @_; if ($token) { - # assign to a hash slice to make a shallow copy of the token. - # I guess we could assign to the hash as (by default) there are not - # contents, but that seems less helpful if someone wants to subclass us - @{$self}{keys %$token} = values %$token; + # assign to a hash slice to make a shallow copy of the token. + # I guess we could assign to the hash as (by default) there are not + # contents, but that seems less helpful if someone wants to subclass us + @{$self}{ keys %$token } = values %$token; } return $self; } diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Bailout.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Bailout.pm index a4c9bbd..f80ea29 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Bailout.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Result/Bailout.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Bailout - Bailout result token. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Comment.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Comment.pm index 04a2ce0..d07e1d2 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Comment.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Result/Comment.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Comment - Comment result token. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Plan.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Plan.pm index 3225586..a577212 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Plan.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Result/Plan.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Plan - Plan result token. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Pragma.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Pragma.pm index b0ea82a..df7a4fd 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Pragma.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Result/Pragma.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Pragma - TAP pragma token. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Test.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Test.pm index 4c12f61..7431769 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Test.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Result/Test.pm @@ -14,11 +14,11 @@ TAP::Parser::Result::Test - Test result token. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Unknown.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Unknown.pm index 0316fb0..f0ed6e3 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Unknown.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Result/Unknown.pm @@ -14,11 +14,11 @@ TAP::Parser::Result::Unknown - Unknown result token. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/Version.pm b/ext/Test-Harness/lib/TAP/Parser/Result/Version.pm index 3688f2b..d666091 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Result/Version.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Result/Version.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Version - TAP syntax version token. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION diff --git a/ext/Test-Harness/lib/TAP/Parser/Result/YAML.pm b/ext/Test-Harness/lib/TAP/Parser/Result/YAML.pm index d1e9cf6..0dcc95b 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Result/YAML.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Result/YAML.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::YAML - YAML result token. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION diff --git a/ext/Test-Harness/lib/TAP/Parser/ResultFactory.pm b/ext/Test-Harness/lib/TAP/Parser/ResultFactory.pm index 5d33935..10deb63 100644 --- a/ext/Test-Harness/lib/TAP/Parser/ResultFactory.pm +++ b/ext/Test-Harness/lib/TAP/Parser/ResultFactory.pm @@ -30,11 +30,11 @@ TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head2 DESCRIPTION diff --git a/ext/Test-Harness/lib/TAP/Parser/Scheduler.pm b/ext/Test-Harness/lib/TAP/Parser/Scheduler.pm index c90432e..0320d19 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Scheduler.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Scheduler.pm @@ -12,11 +12,11 @@ TAP::Parser::Scheduler - Schedule tests during parallel testing =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS @@ -193,7 +193,7 @@ Get a list of all remaining tests. sub get_all { my $self = shift; - my @all = $self->_gather( $self->{schedule} ); + my @all = $self->_gather( $self->{schedule} ); $self->{count} = @all; @all; } @@ -202,7 +202,7 @@ sub _gather { my ( $self, $rule ) = @_; return unless defined $rule; return $rule unless 'ARRAY' eq ref $rule; - return map { defined () ? $self->_gather($_) : () } map {@$_} @$rule; + return map { defined() ? $self->_gather($_) : () } map {@$_} @$rule; } =head3 C @@ -218,8 +218,8 @@ sub get_job { $self->{count} ||= $self->get_all; my @jobs = $self->_find_next_job( $self->{schedule} ); if (@jobs) { - --$self->{count}; - return $jobs[0]; + --$self->{count}; + return $jobs[0]; } return TAP::Parser::Scheduler::Spinner->new @@ -244,11 +244,12 @@ sub _find_next_job { my @queue = (); my $index = 0; - while ($index < @$rule) { + while ( $index < @$rule ) { my $seq = $rule->[$index]; + # Prune any exhausted items. shift @$seq while @$seq && _is_empty( $seq->[0] ); - if ( @$seq ) { + if (@$seq) { if ( defined $seq->[0] ) { if ( 'ARRAY' eq ref $seq->[0] ) { push @queue, $seq; @@ -262,6 +263,7 @@ sub _find_next_job { ++$index; } else { + # Remove the empty sub-array from the array splice @$rule, $index, 1; } diff --git a/ext/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm b/ext/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm index fe55faf..8003fc0 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Job - A single testing job. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm b/ext/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm index 25f1b4a..53cfc92 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Spinner - A no-op job. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/TAP/Parser/Source.pm b/ext/Test-Harness/lib/TAP/Parser/Source.pm index 3b10482..c04adcf 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Source.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Source.pm @@ -17,11 +17,11 @@ TAP::Parser::Source - Stream output from some source =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/TAP/Parser/Source/Perl.pm b/ext/Test-Harness/lib/TAP/Parser/Source/Perl.pm index 444b429..2a2586e 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Source/Perl.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Source/Perl.pm @@ -18,11 +18,11 @@ TAP::Parser::Source::Perl - Stream Perl output =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS @@ -106,37 +106,42 @@ this is a TAP::Parser instance. sub get_stream { my ( $self, $factory ) = @_; - my @extra_libs; - my @switches = $self->_switches; my $path_sep = $Config{path_sep}; my $path_pat = qr{$path_sep}; + # Filter out any -I switches to be handled as libs later. + # # Nasty kludge. It might be nicer if we got the libs separately # although at least this way we find any -I switches that were # supplied other then as explicit libs. + # # We filter out any names containing colons because they will break # PERL5LIB my @libs; - for ( grep { $_ !~ $path_pat } @switches ) { - push @libs, $1 if / ^ ['"]? -I (.*?) ['"]? $ /x; - } - - my $previous = $ENV{PERL5LIB}; - if ($previous) { - push @libs, split( $path_pat, $previous ); + my @filtered_switches; + for (@switches) { + if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) { + push @libs, $1; + } + else { + push @filtered_switches, $_; + } } + @switches = @filtered_switches; my $setup = sub { if (@libs) { - $ENV{PERL5LIB} = join( $path_sep, @libs ); + $ENV{PERL5LIB} + = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} ); } }; # Cargo culted from comments seen elsewhere about VMS / environment # variables. I don't know if this is actually necessary. + my $previous = $ENV{PERL5LIB}; my $teardown = sub { - if ($previous) { + if ( defined $previous ) { $ENV{PERL5LIB} = $previous; } else { @@ -148,12 +153,7 @@ sub get_stream { # PERL5LIB as -I switches and place PERL5OPT on the command line # in order that it be seen. if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) { - push @switches, - $self->_libs2switches( - split $path_pat, - $ENV{PERL5LIB} || $ENV{PERLLIB} || '' - ); - + push @switches, $self->_libs2switches(@libs); push @switches, split_shell( $ENV{PERL5OPT} ); } @@ -262,11 +262,12 @@ sub _switches { my $taint = $self->get_taint($shebang); push @switches, "-$taint" if defined $taint; - # Quote the argument if there's any whitespace in it, or if - # we're VMS, since VMS requires all parms quoted. Also, don't quote - # it if it's already quoted. - for (@switches) { - $_ = qq["$_"] if ( ( /\s/ || IS_VMS ) && !/^".*"$/ ); + # Quote the argument if we're VMS, since VMS will downcase anything + # not quoted. + if (IS_VMS) { + for (@switches) { + $_ = qq["$_"]; + } } return @switches; diff --git a/ext/Test-Harness/lib/TAP/Parser/Utils.pm b/ext/Test-Harness/lib/TAP/Parser/Utils.pm index 85174c0..8aabd21 100644 --- a/ext/Test-Harness/lib/TAP/Parser/Utils.pm +++ b/ext/Test-Harness/lib/TAP/Parser/Utils.pm @@ -13,11 +13,11 @@ TAP::Parser::Utils - Internal TAP::Parser utilities =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm b/ext/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm index cc39350..9eba0c3 100644 --- a/ext/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm +++ b/ext/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm @@ -6,7 +6,7 @@ use vars qw($VERSION @ISA); use TAP::Object (); @ISA = 'TAP::Object'; -$VERSION = '3.14'; +$VERSION = '3.16'; # TODO: # Handle blessed object syntax @@ -270,7 +270,7 @@ TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator =head1 VERSION -Version 3.14 +Version 3.16 =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm b/ext/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm index 98301a3..6c2e636 100644 --- a/ext/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm +++ b/ext/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm @@ -6,7 +6,7 @@ use vars qw($VERSION @ISA); use TAP::Object (); @ISA = 'TAP::Object'; -$VERSION = '3.14'; +$VERSION = '3.16'; my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x; my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x; @@ -147,7 +147,7 @@ TAP::Parser::YAMLish::Writer - Write YAMLish data =head1 VERSION -Version 3.14 +Version 3.16 =head1 SYNOPSIS diff --git a/ext/Test-Harness/lib/Test/Harness.pm b/ext/Test-Harness/lib/Test/Harness.pm index 24566ba..5a7a5ea 100644 --- a/ext/Test-Harness/lib/Test/Harness.pm +++ b/ext/Test-Harness/lib/Test/Harness.pm @@ -44,11 +44,11 @@ Test::Harness - Run Perl standard test scripts with statistics =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; # Backwards compatibility for exportable variable names. *verbose = *Verbose; @@ -128,40 +128,20 @@ sub _aggregate { # Don't propagate to our children local $ENV{HARNESS_OPTIONS}; - if (IS_VMS) { - - # Jiggery pokery doesn't appear to work on VMS - so disable it - # pending investigation. - _aggregate_tests( $harness, $aggregate, @tests ); - } - else { - my $path_sep = $Config{path_sep}; - my $path_pat = qr{$path_sep}; - my @extra_inc = _filtered_inc(); - - # Supply -I switches in taint mode - $harness->callback( - parser_args => sub { - my ( $args, $test ) = @_; - if ( _has_taint( $test->[0] ) ) { - push @{ $args->{switches} }, map {"-I$_"} _filtered_inc(); - } - } - ); - - my $previous = $ENV{PERL5LIB}; - local $ENV{PERL5LIB}; + _apply_extra_INC($harness); + _aggregate_tests( $harness, $aggregate, @tests ); +} - if ($previous) { - push @extra_inc, split( $path_pat, $previous ); - } +# Make sure the child seens all the extra junk in @INC +sub _apply_extra_INC { + my $harness = shift; - if (@extra_inc) { - $ENV{PERL5LIB} = join( $path_sep, @extra_inc ); + $harness->callback( + parser_args => sub { + my ( $args, $test ) = @_; + push @{ $args->{switches} }, map {"-I$_"} _filtered_inc(); } - - _aggregate_tests( $harness, $aggregate, @tests ); - } + ); } sub _aggregate_tests { @@ -320,8 +300,14 @@ sub _filtered_inc { sub _default_inc { return @inc if @inc; + + local $ENV{PERL5LIB}; + local $ENV{PERLLIB}; + my $perl = $ENV{HARNESS_PERL} || $^X; - chomp( @inc = `$perl -le "print join qq[\\n], \@INC"` ); + + # Avoid using -l for the benefit of Perl 6 + chomp( @inc = `$perl -e "print join qq[\\n], \@INC, q[]"` ); return @inc; } } diff --git a/ext/Test-Harness/t/aggregator.t b/ext/Test-Harness/t/aggregator.t index b3aff2a..c8e32a1 100644 --- a/ext/Test-Harness/t/aggregator.t +++ b/ext/Test-Harness/t/aggregator.t @@ -3,7 +3,7 @@ use strict; use lib 't/lib'; -use Test::More tests => 79; +use Test::More tests => 81; use TAP::Parser; use TAP::Parser::IteratorFactory; @@ -105,6 +105,10 @@ can_ok $agg, 'total'; is $agg->total, $agg->passed + $agg->failed, '... and we should have the correct number of total tests'; +can_ok $agg, 'planned'; +is $agg->planned, $agg->passed + $agg->failed, + '... and we should have the correct number of planned tests'; + can_ok $agg, 'has_problems'; ok $agg->has_problems, '... and it should report true if there are problems'; diff --git a/ext/Test-Harness/t/compat/failure.t b/ext/Test-Harness/t/compat/failure.t index b442567..d199b7b 100644 --- a/ext/Test-Harness/t/compat/failure.t +++ b/ext/Test-Harness/t/compat/failure.t @@ -22,9 +22,10 @@ use Test::Harness; my $sample_tests; if ( $ENV{PERL_CORE} ) { my $updir = File::Spec->updir; - $sample_tests - = File::Spec->catdir( $updir, 'ext', 'Test-Harness', 't', - 'sample-tests' ); + $sample_tests = File::Spec->catdir( + $updir, 'ext', 'Test-Harness', 't', + 'sample-tests' + ); } else { my $curdir = File::Spec->curdir; diff --git a/ext/Test-Harness/t/compat/inc-propagation.t b/ext/Test-Harness/t/compat/inc-propagation.t index ffa5370..c0d62b0 100644 --- a/ext/Test-Harness/t/compat/inc-propagation.t +++ b/ext/Test-Harness/t/compat/inc-propagation.t @@ -5,6 +5,10 @@ use strict; use lib 't/lib'; +use Config; + +local + $ENV{PERL5OPT}; # avoid any user-provided PERL5OPT from contaminating @INC sub has_crazy_patch { my $sentinel = 'blirpzoffle'; @@ -32,9 +36,8 @@ my $test_template = <<'END'; use Test::More tests => 2; -# Make sure we did something sensible with PERL5LIB +is $INC[0], "wibble", 'basic order of @INC preserved' or diag "\@INC: @INC"; like $ENV{PERL5LIB}, qr{wibble}; -ok grep { $_ eq 'wibble' } @INC; END diff --git a/ext/Test-Harness/t/file.t b/ext/Test-Harness/t/file.t new file mode 100644 index 0000000..68ad045 --- /dev/null +++ b/ext/Test-Harness/t/file.t @@ -0,0 +1,402 @@ +#!/usr/bin/perl -w + +BEGIN { + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +use Test::More; + +use TAP::Harness; + +my $HARNESS = 'TAP::Harness'; + +my $source_tests + = $ENV{PERL_CORE} ? '../ext/Test-Harness/t/source_tests' : 't/source_tests'; +my $sample_tests + = $ENV{PERL_CORE} ? '../ext/Test-Harness/t/sample-tests' : 't/sample-tests'; + +plan tests => 41; + +# note that this test will always pass when run through 'prove' +ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set'; +ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set'; + +{ + my @output; + local $^W; + require TAP::Formatter::Base; + local *TAP::Formatter::Base::_output = sub { + my $self = shift; + push @output => grep { $_ ne '' } + map { + local $_ = $_; + chomp; + trim($_) + } map { split /\n/ } @_; + }; + my $harness = TAP::Harness->new( { verbosity => 1 } ); + my $harness_whisper = TAP::Harness->new( { verbosity => -1 } ); + my $harness_mute = TAP::Harness->new( { verbosity => -2 } ); + my $harness_directives = TAP::Harness->new( { directives => 1 } ); + my $harness_failures = TAP::Harness->new( { failures => 1 } ); + + can_ok $harness, 'runtests'; + + # normal tests in verbose mode + + ok my $aggregate = _runtests( $harness, "$source_tests/harness" ), + '... runtests returns the aggregate'; + + isa_ok $aggregate, 'TAP::Parser::Aggregator'; + + chomp(@output); + + my @expected = ( + "$source_tests/harness ..", + '1..1', + 'ok 1 - this is a test', + 'ok', + 'All tests successful.', + ); + my $status = pop @output; + my $expected_status = qr{^Result: PASS$}; + my $summary = pop @output; + my $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs}; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # use an alias for test name + + @output = (); + ok $aggregate + = _runtests( $harness, [ "$source_tests/harness", 'My Nice Test' ] ), + '... runtests returns the aggregate'; + + isa_ok $aggregate, 'TAP::Parser::Aggregator'; + + chomp(@output); + + @expected = ( + 'My Nice Test ..', + '1..1', + 'ok 1 - this is a test', + 'ok', + 'All tests successful.', + ); + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs}; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # run same test twice + + @output = (); + ok $aggregate = _runtests( + $harness, [ "$source_tests/harness", 'My Nice Test' ], + [ "$source_tests/harness", 'My Nice Test Again' ] + ), + '... runtests returns the aggregate'; + + isa_ok $aggregate, 'TAP::Parser::Aggregator'; + + chomp(@output); + + @expected = ( + 'My Nice Test ........', + '1..1', + 'ok 1 - this is a test', + 'ok', + 'My Nice Test Again ..', + '1..1', + 'ok 1 - this is a test', + 'ok', + 'All tests successful.', + ); + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr{^Files=2, Tests=2, \d+ wallclock secs}; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # normal tests in quiet mode + + @output = (); + _runtests( $harness_whisper, "$source_tests/harness" ); + + chomp(@output); + @expected = ( + "$source_tests/harness .. ok", + 'All tests successful.', + ); + + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # normal tests in really_quiet mode + + @output = (); + _runtests( $harness_mute, "$source_tests/harness" ); + + chomp(@output); + @expected = ( + 'All tests successful.', + ); + + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # normal tests with failures + + @output = (); + _runtests( $harness, "$source_tests/harness_failure" ); + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + + my @summary = @output[ 5 .. $#output ]; + @output = @output[ 0 .. 4 ]; + + @expected = ( + "$source_tests/harness_failure ..", + '1..2', + 'ok 1 - this is a test', + 'not ok 2 - this is another test', + 'Failed 1/2 subtests', + ); + + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + + my @expected_summary = ( + 'Test Summary Report', + '-------------------', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + ); + + is_deeply \@summary, \@expected_summary, + '... and the failure summary should also be correct'; + + # quiet tests with failures + + @output = (); + _runtests( $harness_whisper, "$source_tests/harness_failure" ); + + $status = pop @output; + $summary = pop @output; + @expected = ( + "$source_tests/harness_failure ..", + 'Failed 1/2 subtests', + 'Test Summary Report', + '-------------------', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + ); + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + + # really quiet tests with failures + + @output = (); + _runtests( $harness_mute, "$source_tests/harness_failure" ); + + $status = pop @output; + $summary = pop @output; + @expected = ( + 'Test Summary Report', + '-------------------', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + ); + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + + # only show directives + + @output = (); + _runtests( + $harness_directives, + "$source_tests/harness_directives" + ); + + chomp(@output); + + @expected = ( + "$source_tests/harness_directives ..", + 'not ok 2 - we have a something # TODO some output', + "ok 3 houston, we don't have liftoff # SKIP no funding", + 'ok', + 'All tests successful.', + + # ~TODO {{{ this should be an option + #'Test Summary Report', + #'-------------------', + #"$source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)", + #'Tests skipped:', + #'3', + # }}} + ); + + $status = pop @output; + $summary = pop @output; + $expected_summary = qr/^Files=1, Tests=3, \d+ wallclock secs/; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + like $status, qr{^Result: PASS$}, + '... and the status line should be correct'; + + # normal tests with bad tap + + @output = (); + _runtests( $harness, "$source_tests/harness_badtap" ); + chomp(@output); + + @output = map { trim($_) } @output; + $status = pop @output; + @summary = @output[ 6 .. ( $#output - 1 ) ]; + @output = @output[ 0 .. 5 ]; + @expected = ( + "$source_tests/harness_badtap ..", + '1..2', + 'ok 1 - this is a test', + 'not ok 2 - this is another test', + '1..2', + 'Failed 1/2 subtests', + ); + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + @expected_summary = ( + 'Test Summary Report', + '-------------------', + "$source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + 'Parse errors: More than one plan found in TAP output', + ); + is_deeply \@summary, \@expected_summary, + '... and the badtap summary should also be correct'; + + # coverage testing for _should_show_failures + # only show failures + + @output = (); + _runtests( $harness_failures, "$source_tests/harness_failure" ); + + chomp(@output); + + @expected = ( + "$source_tests/harness_failure ..", + 'not ok 2 - this is another test', + 'Failed 1/2 subtests', + 'Test Summary Report', + '-------------------', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + ); + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; + is_deeply \@output, \@expected, '... and the output should be correct'; + + # check the status output for no tests + + @output = (); + _runtests( $harness_failures, "$sample_tests/no_output" ); + + chomp(@output); + + @expected = ( + "$sample_tests/no_output ..", + 'No subtests run', + 'Test Summary Report', + '-------------------', + "$sample_tests/no_output (Wstat: 0 Tests: 0 Failed: 0)", + 'Parse errors: No plan found in TAP output', + ); + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; + is_deeply \@output, \@expected, '... and the output should be correct'; + + #XXXX +} + +sub trim { + $_[0] =~ s/^\s+|\s+$//g; + return $_[0]; +} + +sub _runtests { + my ( $harness, @tests ) = @_; + local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; + my $aggregate = $harness->runtests(@tests); + return $aggregate; +} + diff --git a/ext/Test-Harness/t/harness-bailout.t b/ext/Test-Harness/t/harness-bailout.t new file mode 100644 index 0000000..0ee8a79 --- /dev/null +++ b/ext/Test-Harness/t/harness-bailout.t @@ -0,0 +1,58 @@ +#!perl + +use strict; +use File::Spec; + +BEGIN { + *CORE::GLOBAL::exit = sub { die '!exit called!' }; +} + +use TAP::Harness; +use Test::More; + +my @jobs = ( + { name => 'sequential', + args => { verbosity => -9 }, + }, + { name => 'parallel', + args => { verbosity => -9, jobs => 2 }, + }, +); + +plan tests => @jobs * 2; + +for my $test (@jobs) { + my $name = $test->{name}; + my $args = $test->{args}; + my $harness = TAP::Harness->new($args); + eval { + local ( *OLDERR, *OLDOUT ); + open OLDERR, '>&STDERR' or die $!; + open OLDOUT, '>&STDOUT' or die $!; + my $devnull = File::Spec->devnull; + open STDERR, ">$devnull" or die $!; + open STDOUT, ">$devnull" or die $!; + + $harness->runtests( + File::Spec->catfile( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir, 'ext', 'Test-Harness' ) + : () + ), + 't', + 'sample-tests', + 'bailout' + ) + ); + + open STDERR, '>&OLDERR' or die $!; + open STDOUT, '>&OLDOUT' or die $!; + }; + my $err = $@; + unlike $err, qr{!exit called!}, "$name: didn't exit"; + like $err, qr{FAILED--Further testing stopped: GERONIMMMOOOOOO!!!}, + "$name: bailout message"; +} + +# vim:ts=2:sw=2:et:ft=perl + diff --git a/ext/Test-Harness/t/harness.t b/ext/Test-Harness/t/harness.t index aa236df..c9f835a 100644 --- a/ext/Test-Harness/t/harness.t +++ b/ext/Test-Harness/t/harness.t @@ -83,8 +83,7 @@ foreach my $test_args ( get_arg_sets() ) { { my @output; local $^W; - local *TAP::Formatter::Console::_should_show_count = sub {0}; - local *TAP::Formatter::Console::_output = sub { + local *TAP::Formatter::Base::_output = sub { my $self = shift; push @output => grep { $_ ne '' } map { @@ -93,11 +92,16 @@ foreach my $test_args ( get_arg_sets() ) { trim($_) } @_; }; - my $harness = TAP::Harness->new( { verbosity => 1 } ); - my $harness_whisper = TAP::Harness->new( { verbosity => -1 } ); - my $harness_mute = TAP::Harness->new( { verbosity => -2 } ); - my $harness_directives = TAP::Harness->new( { directives => 1 } ); - my $harness_failures = TAP::Harness->new( { failures => 1 } ); + my $harness = TAP::Harness->new( + { verbosity => 1, formatter_class => "TAP::Formatter::Console" } ); + my $harness_whisper = TAP::Harness->new( + { verbosity => -1, formatter_class => "TAP::Formatter::Console" } ); + my $harness_mute = TAP::Harness->new( + { verbosity => -2, formatter_class => "TAP::Formatter::Console" } ); + my $harness_directives = TAP::Harness->new( + { directives => 1, formatter_class => "TAP::Formatter::Console" } ); + my $harness_failures = TAP::Harness->new( + { failures => 1, formatter_class => "TAP::Formatter::Console" } ); colorize($harness); @@ -113,7 +117,7 @@ foreach my $test_args ( get_arg_sets() ) { chomp(@output); my @expected = ( - "$source_tests/harness....", + "$source_tests/harness ..", '1..1', '[[reset]]', 'ok 1 - this is a test', @@ -144,7 +148,7 @@ foreach my $test_args ( get_arg_sets() ) { chomp(@output); @expected = ( - 'My Nice Test....', + 'My Nice Test ..', '1..1', '[[reset]]', 'ok 1 - this is a test', @@ -177,13 +181,13 @@ foreach my $test_args ( get_arg_sets() ) { chomp(@output); @expected = ( - 'My Nice Test..........', + 'My Nice Test ........', '1..1', '[[reset]]', 'ok 1 - this is a test', '[[reset]]', 'ok', - 'My Nice Test Again....', + 'My Nice Test Again ..', '1..1', '[[reset]]', 'ok 1 - this is a test', @@ -209,7 +213,7 @@ foreach my $test_args ( get_arg_sets() ) { chomp(@output); @expected = ( - "$source_tests/harness....", + "$source_tests/harness ..", 'ok', 'All tests successful.', ); @@ -261,7 +265,7 @@ foreach my $test_args ( get_arg_sets() ) { @output = @output[ 0 .. 9 ]; @expected = ( - "$source_tests/harness_failure....", + "$source_tests/harness_failure ..", '1..2', '[[reset]]', 'ok 1 - this is a test', @@ -302,7 +306,7 @@ foreach my $test_args ( get_arg_sets() ) { $status = pop @output; $summary = pop @output; @expected = ( - "$source_tests/harness_failure....", + "$source_tests/harness_failure ..", 'Failed 1/2 subtests', 'Test Summary Report', '-------------------', @@ -349,7 +353,7 @@ foreach my $test_args ( get_arg_sets() ) { chomp(@output); @expected = ( - "$source_tests/harness_directives....", + "$source_tests/harness_directives ..", 'not ok 2 - we have a something # TODO some output', "ok 3 houston, we don't have liftoff # SKIP no funding", 'ok', @@ -407,7 +411,7 @@ foreach my $test_args ( get_arg_sets() ) { @summary = @output[ 12 .. ( $#output - 1 ) ]; @output = @output[ 0 .. 11 ]; @expected = ( - "$source_tests/harness_badtap....", + "$source_tests/harness_badtap ..", '1..2', '[[reset]]', 'ok 1 - this is a test', @@ -461,7 +465,7 @@ foreach my $test_args ( get_arg_sets() ) { chomp(@output); @expected = ( - "$source_tests/harness_failure....", + "$source_tests/harness_failure ..", 'not ok 2 - this is another test', 'Failed 1/2 subtests', 'Test Summary Report', @@ -487,7 +491,7 @@ foreach my $test_args ( get_arg_sets() ) { chomp(@output); @expected = ( - "$sample_tests/no_output....", + "$sample_tests/no_output ..", 'No subtests run', 'Test Summary Report', '-------------------', @@ -859,15 +863,15 @@ sub _runtests { { name => 'all the same', input => [ 'foo.t', 'bar.t', 'fletz.t' ], output => [ - [ 'foo.t', 'foo' ], [ 'bar.t', 'bar' ], - [ 'fletz.t', 'fletz' ] + [ 'foo.t', 'foo.t' ], [ 'bar.t', 'bar.t' ], + [ 'fletz.t', 'fletz.t' ] ], }, { name => 'all the same, already cooked', input => [ 'foo.t', [ 'bar.t', 'brip' ], 'fletz.t' ], output => [ - [ 'foo.t', 'foo' ], [ 'bar.t', 'brip' ], - [ 'fletz.t', 'fletz' ] + [ 'foo.t', 'foo.t' ], [ 'bar.t', 'brip' ], + [ 'fletz.t', 'fletz.t' ] ], }, { name => 'different exts', diff --git a/ext/Test-Harness/t/iterators.t b/ext/Test-Harness/t/iterators.t index b24fc37..c82387b 100644 --- a/ext/Test-Harness/t/iterators.t +++ b/ext/Test-Harness/t/iterators.t @@ -83,7 +83,7 @@ my @schedule = ( ); sub _can_open3 { - return $^O eq 'MSWin32' || $Config{d_fork}; + return $Config{d_fork}; } my $factory = TAP::Parser::IteratorFactory->new; diff --git a/ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm b/ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm index 7e285bd..81f79ea 100644 --- a/ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm +++ b/ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm @@ -1,5 +1,7 @@ package App::Prove::Plugin::Dummy; +use strict; + sub import { main::test_log_import(@_); } diff --git a/ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm b/ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm new file mode 100644 index 0000000..ae80003 --- /dev/null +++ b/ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm @@ -0,0 +1,13 @@ +package App::Prove::Plugin::Dummy2; + +use strict; + +sub import { + main::test_log_import(@_); +} + +sub load { + main::test_log_plugin_load(@_); +} + +1; diff --git a/ext/Test-Harness/t/parse.t b/ext/Test-Harness/t/parse.t index 31648da..4bcaba3 100755 --- a/ext/Test-Harness/t/parse.t +++ b/ext/Test-Harness/t/parse.t @@ -951,7 +951,10 @@ END_TAP like pop @die, qr/Can't use/, '...and the message is as we expect'; } -{ +SKIP: { + + # http://markmail.org/message/rkxbo6ft7yorgnzb + skip "Crashes on older Perls", 2 if $] <= 5.008004 || $] == 5.009; # coverage testing of TAP::Parser::_finish diff --git a/ext/Test-Harness/t/perl5lib.t b/ext/Test-Harness/t/perl5lib.t new file mode 100644 index 0000000..c26fd2f --- /dev/null +++ b/ext/Test-Harness/t/perl5lib.t @@ -0,0 +1,48 @@ +#!/usr/bin/perl -w + +# Test that PERL5LIB is propogated from the harness process to the test +# process. + +use strict; +use lib 't/lib'; +use Config; + +my $path_sep = $Config{path_sep}; + +sub has_crazy_patch { + my $sentinel = 'blirpzoffle'; + local $ENV{PERL5LIB} = $sentinel; + my $command = join ' ', + map {qq{"$_"}} ( $^X, '-e', 'print join q(:), @INC' ); + my $path = `$command`; + my @got = ( $path =~ /($sentinel)/g ); + return @got > 1; +} + +use Test::More ( + $^O eq 'VMS' ? ( skip_all => 'VMS' ) + : has_crazy_patch() ? ( skip_all => 'Incompatible @INC patch' ) + : ( tests => 1 ) +); + +use Test::Harness; +use App::Prove; + +# Change PERL5LIB so we ensure it's preserved. +$ENV{PERL5LIB} = join( $path_sep, 'wibble', $ENV{PERL5LIB} ); + +open TEST, ">perl5lib_check.t.tmp"; +print TEST <<"END"; +#!/usr/bin/perl +use strict; +use Test::More tests => 1; +like \$ENV{PERL5LIB}, qr/(^|${path_sep})wibble${path_sep}/; +END +close TEST; + +END { 1 while unlink 'perl5lib_check.t.tmp'; } + +my $h = TAP::Harness->new( { lib => ['something'], verbosity => -3 } ); +ok( !$h->runtests('perl5lib_check.t.tmp')->has_errors ); + +1; diff --git a/ext/Test-Harness/t/prove.t b/ext/Test-Harness/t/prove.t index 20e540d..f8ce128 100644 --- a/ext/Test-Harness/t/prove.t +++ b/ext/Test-Harness/t/prove.t @@ -57,7 +57,6 @@ sub mabs { { my @import_log = (); - sub test_log_import { push @import_log, [@_] } sub get_import_log { @@ -65,6 +64,15 @@ sub mabs { @import_log = (); return @log; } + + my @plugin_load_log = (); + sub test_log_plugin_load { push @plugin_load_log, [@_] } + + sub get_plugin_load_log { + my @log = @plugin_load_log; + @plugin_load_log = (); + return @log; + } } my ( @ATTR, %DEFAULT_ASSERTION, @SCHEDULE ); @@ -1138,6 +1146,47 @@ BEGIN { # START PLAN ], }, + { name => 'Load plugin (args + call load method)', + switches => [ '-P', 'Dummy2=fou,du,fafa', $dummy_test ], + args => { + argv => [qw( one two three )], + }, + expect => { + plugins => ['Dummy2'], + }, + extra => sub { + my @import = get_import_log(); + is_deeply \@import, + [ [ 'App::Prove::Plugin::Dummy2', 'fou', 'du', 'fafa' ] ], + "Plugin loaded OK"; + + my @loaded = get_plugin_load_log(); + is( scalar @loaded, 1, 'Plugin->load called OK' ); + my ( $plugin_class, $args ) = @{ shift @loaded }; + is( $plugin_class, 'App::Prove::Plugin::Dummy2', + 'plugin_class passed' + ); + isa_ok( + $args->{app_prove}, 'App::Prove', + 'app_prove object passed' + ); + is_deeply( + $args->{args}, [qw( fou du fafa )], + 'expected args passed' + ); + }, + plan => 5, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + { name => 'Load module', switches => [ '-M', 'App::Prove::Plugin::Dummy', $dummy_test ], args => { diff --git a/ext/Test-Harness/t/proverun.t b/ext/Test-Harness/t/proverun.t index f0e9ae2..0971684 100644 --- a/ext/Test-Harness/t/proverun.t +++ b/ext/Test-Harness/t/proverun.t @@ -31,7 +31,7 @@ BEGIN { }, ); foreach my $test (@tests) { - + # let's fully expand that filename $test->{file} = File::Spec->catfile( ( $ENV{PERL_CORE} diff --git a/ext/Test-Harness/t/regression.t b/ext/Test-Harness/t/regression.t index 8fc312d..28baee4 100644 --- a/ext/Test-Harness/t/regression.t +++ b/ext/Test-Harness/t/regression.t @@ -2562,97 +2562,102 @@ my %samples = ( version => 12, }, - stdout_stderr => { - results => [ - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'comments', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 1, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 2, - description => '', - explanation => '', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 3, - description => '', - explanation => '', - }, - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'comment', - }, - { actual_passed => TRUE, - is_actual_ok => TRUE, - passed => TRUE, - is_ok => TRUE, - is_test => TRUE, - has_skip => FALSE, - has_todo => FALSE, - number => 4, - description => '', - explanation => '', - }, - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'more ignored stuff', - }, - { is_comment => TRUE, - passed => TRUE, - is_ok => TRUE, - comment => 'and yet more', - }, - { is_plan => TRUE, - passed => TRUE, - is_ok => TRUE, - raw => '1..4', + # For some reason mixing stdout with stderr is unreliable on Windows + ( $IsWin32 + ? () + : ( stdout_stderr => { + results => [ + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comments', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => '', + explanation => '', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comment', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'more ignored stuff', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'and yet more', + }, + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..4', + tests_planned => 4, + }, + ], + plan => '1..4', + passed => [ 1 .. 4 ], + actual_passed => [ 1 .. 4 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, tests_planned => 4, - }, - ], - plan => '1..4', - passed => [ 1 .. 4 ], - actual_passed => [ 1 .. 4 ], - failed => [], - actual_failed => [], - todo => [], - todo_passed => [], - skipped => [], - good_plan => TRUE, - is_good_plan => TRUE, - tests_planned => 4, - tests_run => 4, - parse_errors => [], - 'exit' => 0, - wait => 0, - version => 12, - need_open3 => 1, - }, + tests_run => 4, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + need_open3 => 1, + } + ) + ), junk_before_plan => { results => [ diff --git a/ext/Test-Harness/t/taint.t b/ext/Test-Harness/t/taint.t index 91335ac..151ac6f 100644 --- a/ext/Test-Harness/t/taint.t +++ b/ext/Test-Harness/t/taint.t @@ -10,11 +10,10 @@ BEGIN { } } -# Test that options in PERL5LIB and PERL5OPT are propogated to tainted -# tests +# Test that options in PERL5OPT are propogated to tainted tests use strict; -use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : ( tests => 3 ) ); +use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : ( tests => 1 ) ); use Config; use TAP::Parser; @@ -30,7 +29,13 @@ sub run_test_file { printf TEST $test_template, @args; close TEST; - my $p = TAP::Parser->new( { source => $test_file } ); + my $p = TAP::Parser->new( + { source => $test_file, + + # Test taint when there's spaces in a -I path + switches => [q["-Ifoo bar"]], + } + ); 1 while $p->next; ok !$p->has_problems; @@ -38,35 +43,6 @@ sub run_test_file { } { - local $ENV{PERL5LIB} = join $Config{path_sep}, grep defined, 'wibble', - $ENV{PERL5LIB}; - run_test_file( <<'END', $lib_path ); -#!/usr/bin/perl -T - -BEGIN { unshift @INC, ( %s ); } -use Test::More tests => 1; - -ok grep(/^wibble$/, @INC) or diag join "\n", @INC; -END -} - -{ - my $perl5lib = $ENV{PERL5LIB}; - local $ENV{PERL5LIB}; - local $ENV{PERLLIB} = join $Config{path_sep}, grep defined, 'wibble', - $perl5lib; - run_test_file( <<'END', $lib_path ); -#!/usr/bin/perl -T - -BEGIN { unshift @INC, ( %s ); } -use Test::More tests => 1; - -ok grep(/^wibble$/, @INC) or diag join "\n", @INC; -END -} - -{ - local $ENV{PERL5LIB} = join $Config{path_sep}, @INC; local $ENV{PERL5OPT} = '-Mstrict'; run_test_file(<<'END'); #!/usr/bin/perl -T