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
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
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
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.
effect of this is that C<PERL5LIB> is honoured even when prove is run in
taint mode.
+=head1 PLUGINS
+
+Plugins can be loaded using the C<< -PI<plugin> >> syntax, eg:
+
+ prove -PMyPlugin
+
+This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
+that, C<MyPlugin>. If the plugin can't be found, C<prove> 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<http://search.cpan.org/search?query=App%3A%3AProve+Plugin>
+
+=head2 Writing Plugins
+
+Please see L<App::Prove/PLUGINS>.
+
=cut
# vim:ts=4:sw=4:et:sta
use App::Prove::State;
use Carp;
-@ISA = qw(TAP::Object);
-
=head1 NAME
App::Prove - Implements the C<prove> command.
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
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
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<state_class>
-Returns the name of the class used for maintaining state. This class should
-either subclass from C<App::Prove::State> or provide an identical interface.
+Getter/setter for the name of the class used for maintaining state. This
+class should either subclass from C<App::Prove::State> or provide an identical
+interface.
=head3 C<state_manager>
-Getter/setter for the an instane of the C<state_class>.
+Getter/setter for the instance of the C<state_class>.
=cut
-sub state_class {
- return 'App::Prove::State';
-}
-
=head3 C<add_rc_file>
$prove->add_rc_file('myproj/.proverc');
}
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";
}
}
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);
}
=item C<state>
+=item C<state_class>
+
=item C<taint_fail>
=item C<taint_warn>
=item C<warnings_warn>
=back
+
+=head1 PLUGINS
+
+C<App::Prove> provides support for 3rd-party plugins. These are currently
+loaded at run-time, I<after> arguments have been parsed (so you can not
+change the way arguments are processed, sorry), typically with the
+C<< -PI<plugin> >> switch, eg:
+
+ prove -PMyPlugin
+
+This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
+that, C<MyPlugin>. If the plugin can't be found, C<prove> 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<load()> class method (if it has one),
+along with a reference to the C<App::Prove> 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<import()>
+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<prove>, L<TAP::Harness>
+
+=cut
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;
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
=head3 C<new>
+Accepts a hashref with the following key/value pairs:
+
+=over 4
+
+=item * C<store>
+
+The filename of the data store holding the data that App::Prove::State reads.
+
+=item * C<extension> (optional)
+
+The test name extension. Defaults to C<.t>.
+
+=item * C<result_class> (optional)
+
+The name of the C<result_class>. Defaults to C<App::Prove::State::Result>.
+
+=back
+
=cut
# override TAP::Base::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;
=head2 C<result_class>
-Returns the name of the class used for tracking test results. This class
-should either subclass from C<App::Prove::State::Result> or provide an
+Getter/setter for the name of the class used for tracking test results. This
+class should either subclass from C<App::Prove::State::Result> or provide an
identical interface.
=cut
-sub result_class {
- return 'App::Prove::State::Result';
-}
-
=head2 C<extension>
Get or set the extension files must have in order to be considered
sub results {
my $self = shift;
- $self->{_} || $self->result_class->new
+ $self->{_} || $self->result_class->new;
}
=head2 C<commit>
sub commit {
my $self = shift;
- if ( $self->{should_save} && defined( my $store = $self->{store} ) ) {
- $self->save($store);
+ if ( $self->{should_save} ) {
+ $self->save;
}
}
=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
# 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 );
$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);
=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;
}
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
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;
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;
}
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
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 ) {
The number of times the test has failed.
+=head3 C<parser>
+
+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;
}
=head1 NAME
-TAP::Base - Base class that provides common functionality to L<TAP::Parser> and L<TAP::Harness>
+TAP::Base - Base class that provides common functionality to L<TAP::Parser>
+and L<TAP::Harness>
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
my $GOT_TIME_HIRES;
=head2 Class Methods
-=head3 C<new>
-
=cut
-sub new {
- my ( $class, $arg_for ) = @_;
-
- my $self = bless {}, $class;
- return $self->_initialize($arg_for);
-}
-
sub _initialize {
my ( $self, $arg_for, $ok_callback ) = @_;
--- /dev/null
+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<new>
+
+ my %args = (
+ verbose => 1,
+ )
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console> object. If
+a L<TAP::Harness> is created with no C<formatter> a
+C<TAP::Formatter::Console> is automatically created. If any of the
+following options were given to TAP::Harness->new they well be passed to
+this constructor which accepts an optional hashref whose allowed keys are:
+
+=over 4
+
+=item * C<verbosity>
+
+Set the verbosity level.
+
+=item * C<verbose>
+
+Printing individual test results to STDOUT.
+
+=item * C<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if available.
+
+=item * C<failures>
+
+Only show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<quiet>
+
+Suppressing some test output (mostly failures while tests are running).
+
+=item * C<really_quiet>
+
+Suppressing everything but the tests summary.
+
+=item * C<silent>
+
+Suppressing all output.
+
+=item * C<errors>
+
+If parse errors are found in the TAP output, a note of this will be made
+in the summary report. To see all of the parse errors, set this argument to
+true:
+
+ errors => 1
+
+=item * C<directives>
+
+If set to a true value, only test results with directives will be displayed.
+This overrides other settings such as C<verbose> or C<failures>.
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=item * C<color>
+
+If defined specifies whether color output is desired. If C<color> is not
+defined it will default to color output if color support is available on
+the current platform and output is not being redirected.
+
+=item * C<jobs>
+
+The number of concurrent jobs this formatter will handle.
+
+=item * C<show_count>
+
+Boolean value. If false, disables the C<X/Y> test count which shows up while
+tests are running.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+=head3 C<prepare>
+
+Called by Test::Harness before any test output is generated.
+
+This is an advisory and may not be called in the case where tests are
+being supplied to Test::Harness by an iterator.
+
+=cut
+
+sub prepare {
+ my ( $self, @tests ) = @_;
+
+ my $longest = 0;
+
+ foreach my $test (@tests) {
+ $longest = length $test if length $test > $longest;
+ }
+
+ $self->_longest($longest);
+}
+
+sub _format_now { strftime "[%H:%M:%S]", localtime }
+
+sub _format_name {
+ my ( $self, $test ) = @_;
+ my $name = $test;
+ my $periods = '.' x ( $self->_longest + 2 - length $test );
+ $periods = " $periods ";
+
+ if ( $self->timer ) {
+ my $stamp = $self->_format_now();
+ return "$stamp $name$periods";
+ }
+ else {
+ return "$name$periods";
+ }
+
+}
+
+=head3 C<open_test>
+
+Called to create a new test session. A test session looks like this:
+
+ my $session = $formatter->open_test( $test, $parser );
+ while ( defined( my $result = $parser->next ) ) {
+ $session->result($result);
+ exit 1 if $result->is_bailout;
+ }
+ $session->close_test;
+
+=cut
+
+sub open_test {
+ die "Unimplemented.";
+}
+
+=head3 C<summary>
+
+ $harness->summary( $aggregate );
+
+C<summary> prints the summary report after all tests are run. The argument is
+an aggregate.
+
+=cut
+
+sub summary {
+ my ( $self, $aggregate ) = @_;
+
+ return if $self->silent;
+
+ my @t = $aggregate->descriptions;
+ my $tests = \@t;
+
+ my $runtime = $aggregate->elapsed_timestr;
+
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+
+ if ( $self->timer ) {
+ $self->_output( $self->_format_now(), "\n" );
+ }
+
+ # TODO: Check this condition still works when all subtests pass but
+ # the exit status is nonzero
+
+ if ( $aggregate->all_passed ) {
+ $self->_output("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;
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
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
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
use TAP::Formatter::Console;
my $harness = TAP::Formatter::Console->new( \%args );
-=cut
-
-sub _initialize {
- my ( $self, $arg_for ) = @_;
- $arg_for ||= {};
-
- $self->SUPER::_initialize($arg_for);
- my %arg_for = %$arg_for; # force a shallow copy
-
- $self->verbosity(0);
-
- for my $name ( keys %VALIDATION_FOR ) {
- my $property = delete $arg_for{$name};
- if ( defined $property ) {
- my $validate = $VALIDATION_FOR{$name};
- $self->$name( $self->$validate($property) );
- }
- }
-
- if ( my @props = keys %arg_for ) {
- $self->_croak(
- "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
- }
-
- $self->stdout( \*STDOUT ) unless $self->stdout;
-
- if ( $self->color ) {
- require TAP::Formatter::Color;
- $self->_colorizer( TAP::Formatter::Color->new );
- }
-
- return $self;
-}
-
-sub verbose { shift->verbosity >= 1 }
-sub quiet { shift->verbosity <= -1 }
-sub really_quiet { shift->verbosity <= -2 }
-sub silent { shift->verbosity <= -3 }
-
-=head1 METHODS
-
-=head2 Class Methods
-
-=head3 C<new>
-
- my %args = (
- verbose => 1,
- )
- my $harness = TAP::Formatter::Console->new( \%args );
-
-The constructor returns a new C<TAP::Formatter::Console> object. If
-a L<TAP::Harness> is created with no C<formatter> a
-C<TAP::Formatter::Console> is automatically created. If any of the
-following options were given to TAP::Harness->new they well be passed to
-this constructor which accepts an optional hashref whose allowed keys are:
-
-=over 4
-
-=item * C<verbosity>
-
-Set the verbosity level.
-
-=item * C<verbose>
-
-Printing individual test results to STDOUT.
-
-=item * C<timer>
-
-Append run time for each test to output. Uses L<Time::HiRes> if available.
-
-=item * C<failures>
-
-Only show test failures (this is a no-op if C<verbose> is selected).
-
-=item * C<quiet>
-
-Suppressing some test output (mostly failures while tests are running).
-
-=item * C<really_quiet>
-
-Suppressing everything but the tests summary.
-
-=item * C<silent>
-
-Suppressing all output.
-
-=item * C<errors>
-
-If parse errors are found in the TAP output, a note of this will be made
-in the summary report. To see all of the parse errors, set this argument to
-true:
-
- errors => 1
-
-=item * C<directives>
-
-If set to a true value, only test results with directives will be displayed.
-This overrides other settings such as C<verbose> or C<failures>.
-
-=item * C<stdout>
-
-A filehandle for catching standard output.
-
-=item * C<color>
-
-If defined specifies whether color output is desired. If C<color> is not
-defined it will default to color output if color support is available on
-the current platform and output is not being redirected.
-
-=item * C<jobs>
-
-The number of concurrent jobs this formatter will handle.
-
-=item * C<show_count>
-
-Boolean value. If false, disables the C<X/Y> test count which shows up while
-tests are running.
-
-=back
-
-Any keys for which the value is C<undef> will be ignored.
-
-=cut
-
-# new supplied by TAP::Base
-
-=head3 C<prepare>
-
-Called by Test::Harness before any test output is generated.
-
-This is an advisory and may not be called in the case where tests are
-being supplied to Test::Harness by an iterator.
-
-=cut
-
-sub prepare {
- my ( $self, @tests ) = @_;
-
- my $longest = 0;
+=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<open_test>
-
-Called to create a new test session. A test session looks like this:
-
- my $session = $formatter->open_test( $test, $parser );
- while ( defined( my $result = $parser->next ) ) {
- $session->result($result);
- exit 1 if $result->is_bailout;
- }
- $session->close_test;
+See L<TAP::Formatter::base>
=cut
return $session;
}
-=head3 C<summary>
-
- $harness->summary( $aggregate );
-
-C<summary> prints the summary report after all tests are run. The argument is
-an aggregate.
-
-=cut
-
-sub summary {
- my ( $self, $aggregate ) = @_;
-
- return if $self->silent;
-
- my @t = $aggregate->descriptions;
- my $tests = \@t;
-
- my $runtime = $aggregate->elapsed_timestr;
-
- my $total = $aggregate->total;
- my $passed = $aggregate->passed;
-
- if ( $self->timer ) {
- $self->_output( $self->_format_now(), "\n" );
- }
-
- # TODO: Check this condition still works when all subtests pass but
- # the exit status is nonzero
-
- if ( $aggregate->all_passed ) {
- $self->_output("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 ) = @_;
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;
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
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;
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<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(
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;
}
}
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};
}
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) {
=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<new>
-
- my %args = (
- formatter => $self,
- )
- my $harness = TAP::Formatter::Console::Session->new( \%args );
-
-The constructor returns a new C<TAP::Formatter::Console::Session> object.
-
-=over 4
-
-=item * C<formatter>
-
-=item * C<parser>
-
-=item * C<name>
-
-=item * C<show_count>
-
-=back
-
-=cut
-
-sub _initialize {
- my ( $self, $arg_for ) = @_;
- $arg_for ||= {};
-
- $self->SUPER::_initialize($arg_for);
- my %arg_for = %$arg_for; # force a shallow copy
-
- for my $name (@ACCESSOR) {
- $self->{$name} = delete $arg_for{$name};
- }
-
- if ( !defined $self->show_count ) {
- $self->{show_count} = 1; # defaults to true
- }
- if ( $self->show_count ) { # but may be a damned lie!
- $self->{show_count} = $self->_should_show_count;
- }
-
- if ( my @props = sort keys %arg_for ) {
- $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
- }
-
- return $self;
-}
-
-=head3 C<header>
-
-Output test preamble
-
-=head3 C<result>
-
-Called by the harness for each line of TAP it receives.
-
-=head3 C<close_test>
-
-Called to close a test session.
-
-=head3 C<clear_for_close>
-
-Called by C<close_test> to clear the line showing test progress, or the parallel
-test ruler, prior to printing the final test result.
-
=cut
sub _get_output_result {
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;
},
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");
}
};
}
-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;
--- /dev/null
+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<TAP::Formatter::base>
+
+=cut
+
+sub open_test {
+ my ( $self, $test, $parser ) = @_;
+
+ my $session = TAP::Formatter::File::Session->new(
+ { name => $test,
+ formatter => $self,
+ parser => $parser,
+ }
+ );
+
+ $session->header;
+
+ return $session;
+}
+
+sub _should_show_count {
+ return 0;
+}
+
+1;
--- /dev/null
+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<TAP::Harness>.
+It is particularly important when running with parallel tests, as it
+ensures that test results are not interleaved, even when run
+verbosely.
+
+=cut
+
+=head1 METHODS
+
+=head2 result
+
+Stores results for later output, all together.
+
+=cut
+
+sub result {
+ my $self = shift;
+ my $result = shift;
+
+ my $parser = $self->parser;
+ my $formatter = $self->formatter;
+
+ if ( $result->is_bailout ) {
+ $formatter->_failure_output(
+ "Bailout called. Further testing stopped: "
+ . $result->explanation
+ . "\n" );
+ return;
+ }
+
+ if (!$formatter->quiet
+ && ( ( $formatter->verbose && !$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;
--- /dev/null
+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<new>
+
+ my %args = (
+ formatter => $self,
+ )
+ my $harness = TAP::Formatter::Console::Session->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console::Session> object.
+
+=over 4
+
+=item * C<formatter>
+
+=item * C<parser>
+
+=item * C<name>
+
+=item * C<show_count>
+
+=back
+
+=cut
+
+sub _initialize {
+ my ( $self, $arg_for ) = @_;
+ $arg_for ||= {};
+
+ $self->SUPER::_initialize($arg_for);
+ my %arg_for = %$arg_for; # force a shallow copy
+
+ for my $name (@ACCESSOR) {
+ $self->{$name} = delete $arg_for{$name};
+ }
+
+ if ( !defined $self->show_count ) {
+ $self->{show_count} = 1; # defaults to true
+ }
+ if ( $self->show_count ) { # but may be a damned lie!
+ $self->{show_count} = $self->_should_show_count;
+ }
+
+ if ( my @props = sort keys %arg_for ) {
+ $self->_croak(
+ "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
+ }
+
+ return $self;
+}
+
+=head3 C<header>
+
+Output test preamble
+
+=head3 C<result>
+
+Called by the harness for each line of TAP it receives.
+
+=head3 C<close_test>
+
+Called to close a test session.
+
+=head3 C<clear_for_close>
+
+Called by C<close_test> to clear the line showing test progress, or the parallel
+test ruler, prior to printing the final test result.
+
+=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;
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
$ENV{HARNESS_ACTIVE} = 1;
$ENV{HARNESS_VERSION} = $VERSION;
=item * C<formatter_class>
The name of the class to use to format output. The default is
-L<TAP::Formatter::Console>.
+L<TAP::Formatter::Console>, or L<TAP::Formatter::File> if the output
+isn't a TTY.
=item * C<multiplexer_class>
$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 );
}
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 );
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 ) = @_;
my ( $session, $job ) = @$stash;
if ( defined $result ) {
$session->result($result);
- exit 1 if $result->is_bailout;
+ $self->_bailout($result) if $result->is_bailout;
}
else {
# 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);
}
}
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<make_scheduler>
=head3 C<jobs>
-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<TAP::Harness::Parallel> 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<fork>
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
return $class->new(@args);
}
+=head3 C<mk_methods>
+
+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;
use Carp qw( confess );
-@ISA = qw(TAP::Base);
-
=head1 NAME
TAP::Parser - Parse L<TAP|Test::Harness::TAP> 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;
}
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
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
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;
=head3 C<descriptions>
-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
=item * passed
+=item * planned
+
=item * skipped
=item * todo
=item * Failed tests
-=item * Parse erros
+=item * Parse errors
=item * Bad exit or wait status
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
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;
}
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head2 DESCRIPTION
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
sub get_all {
my $self = shift;
- my @all = $self->_gather( $self->{schedule} );
+ my @all = $self->_gather( $self->{schedule} );
$self->{count} = @all;
@all;
}
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<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
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;
++$index;
}
else {
+
# Remove the empty sub-array from the array
splice @$rule, $index, 1;
}
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
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 {
# 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} );
}
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;
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
=head1 SYNOPSIS
use TAP::Object ();
@ISA = 'TAP::Object';
-$VERSION = '3.14';
+$VERSION = '3.16';
# TODO:
# Handle blessed object syntax
=head1 VERSION
-Version 3.14
+Version 3.16
=head1 SYNOPSIS
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;
=head1 VERSION
-Version 3.14
+Version 3.16
=head1 SYNOPSIS
=head1 VERSION
-Version 3.14
+Version 3.16
=cut
-$VERSION = '3.14';
+$VERSION = '3.16';
# Backwards compatibility for exportable variable names.
*verbose = *Verbose;
# 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 {
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;
}
}
use strict;
use lib 't/lib';
-use Test::More tests => 79;
+use Test::More tests => 81;
use TAP::Parser;
use TAP::Parser::IteratorFactory;
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';
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;
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';
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
--- /dev/null
+#!/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;
+}
+
--- /dev/null
+#!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
+
{
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 {
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);
chomp(@output);
my @expected = (
- "$source_tests/harness....",
+ "$source_tests/harness ..",
'1..1',
'[[reset]]',
'ok 1 - this is a test',
chomp(@output);
@expected = (
- 'My Nice Test....',
+ 'My Nice Test ..',
'1..1',
'[[reset]]',
'ok 1 - this is a test',
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',
chomp(@output);
@expected = (
- "$source_tests/harness....",
+ "$source_tests/harness ..",
'ok',
'All tests successful.',
);
@output = @output[ 0 .. 9 ];
@expected = (
- "$source_tests/harness_failure....",
+ "$source_tests/harness_failure ..",
'1..2',
'[[reset]]',
'ok 1 - this is a test',
$status = pop @output;
$summary = pop @output;
@expected = (
- "$source_tests/harness_failure....",
+ "$source_tests/harness_failure ..",
'Failed 1/2 subtests',
'Test Summary Report',
'-------------------',
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',
@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',
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',
chomp(@output);
@expected = (
- "$sample_tests/no_output....",
+ "$sample_tests/no_output ..",
'No subtests run',
'Test Summary Report',
'-------------------',
{ 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',
);
sub _can_open3 {
- return $^O eq 'MSWin32' || $Config{d_fork};
+ return $Config{d_fork};
}
my $factory = TAP::Parser::IteratorFactory->new;
package App::Prove::Plugin::Dummy;
+use strict;
+
sub import {
main::test_log_import(@_);
}
--- /dev/null
+package App::Prove::Plugin::Dummy2;
+
+use strict;
+
+sub import {
+ main::test_log_import(@_);
+}
+
+sub load {
+ main::test_log_plugin_load(@_);
+}
+
+1;
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
--- /dev/null
+#!/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;
{
my @import_log = ();
-
sub test_log_import { push @import_log, [@_] }
sub get_import_log {
@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 );
],
},
+ { 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 => {
},
);
foreach my $test (@tests) {
-
+
# let's fully expand that filename
$test->{file} = File::Spec->catfile(
( $ENV{PERL_CORE}
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 => [
}
}
-# 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;
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;
}
{
- 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
projects / p5sagit/p5-mst-13.2.git / commitdiff