Upgrade to Test-Harness-3.16
authorSteve Hay <SteveHay@planit.com>
Fri, 6 Mar 2009 15:22:23 +0000 (15:22 +0000)
committerDavid Mitchell <davem@iabyn.com>
Wed, 15 Apr 2009 19:40:01 +0000 (20:40 +0100)
But keep Test/Harness -> Test-Harness changes from commit f715bbfb20b232d289d3eddf42aec434ddd9dd4c
and do likewise in new files file.t and harness-bailout.t too.

(cherry picked from commit bdaf8c65d37b1e4fb9dee9eed906961f41184db9)

61 files changed:
MANIFEST
ext/Test-Harness/Changes
ext/Test-Harness/bin/prove
ext/Test-Harness/lib/App/Prove.pm
ext/Test-Harness/lib/App/Prove/State.pm
ext/Test-Harness/lib/App/Prove/State/Result.pm
ext/Test-Harness/lib/App/Prove/State/Result/Test.pm
ext/Test-Harness/lib/TAP/Base.pm
ext/Test-Harness/lib/TAP/Formatter/Base.pm [new file with mode: 0644]
ext/Test-Harness/lib/TAP/Formatter/Color.pm
ext/Test-Harness/lib/TAP/Formatter/Console.pm
ext/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm
ext/Test-Harness/lib/TAP/Formatter/Console/Session.pm
ext/Test-Harness/lib/TAP/Formatter/File.pm [new file with mode: 0644]
ext/Test-Harness/lib/TAP/Formatter/File/Session.pm [new file with mode: 0644]
ext/Test-Harness/lib/TAP/Formatter/Session.pm [new file with mode: 0644]
ext/Test-Harness/lib/TAP/Harness.pm
ext/Test-Harness/lib/TAP/Object.pm
ext/Test-Harness/lib/TAP/Parser.pm
ext/Test-Harness/lib/TAP/Parser/Aggregator.pm
ext/Test-Harness/lib/TAP/Parser/Grammar.pm
ext/Test-Harness/lib/TAP/Parser/Iterator.pm
ext/Test-Harness/lib/TAP/Parser/Iterator/Array.pm
ext/Test-Harness/lib/TAP/Parser/Iterator/Process.pm
ext/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm
ext/Test-Harness/lib/TAP/Parser/IteratorFactory.pm
ext/Test-Harness/lib/TAP/Parser/Multiplexer.pm
ext/Test-Harness/lib/TAP/Parser/Result.pm
ext/Test-Harness/lib/TAP/Parser/Result/Bailout.pm
ext/Test-Harness/lib/TAP/Parser/Result/Comment.pm
ext/Test-Harness/lib/TAP/Parser/Result/Plan.pm
ext/Test-Harness/lib/TAP/Parser/Result/Pragma.pm
ext/Test-Harness/lib/TAP/Parser/Result/Test.pm
ext/Test-Harness/lib/TAP/Parser/Result/Unknown.pm
ext/Test-Harness/lib/TAP/Parser/Result/Version.pm
ext/Test-Harness/lib/TAP/Parser/Result/YAML.pm
ext/Test-Harness/lib/TAP/Parser/ResultFactory.pm
ext/Test-Harness/lib/TAP/Parser/Scheduler.pm
ext/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm
ext/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm
ext/Test-Harness/lib/TAP/Parser/Source.pm
ext/Test-Harness/lib/TAP/Parser/Source/Perl.pm
ext/Test-Harness/lib/TAP/Parser/Utils.pm
ext/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm
ext/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm
ext/Test-Harness/lib/Test/Harness.pm
ext/Test-Harness/t/aggregator.t
ext/Test-Harness/t/compat/failure.t
ext/Test-Harness/t/compat/inc-propagation.t
ext/Test-Harness/t/file.t [new file with mode: 0644]
ext/Test-Harness/t/harness-bailout.t [new file with mode: 0644]
ext/Test-Harness/t/harness.t
ext/Test-Harness/t/iterators.t
ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm
ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm [new file with mode: 0644]
ext/Test-Harness/t/parse.t
ext/Test-Harness/t/perl5lib.t [new file with mode: 0644]
ext/Test-Harness/t/prove.t
ext/Test-Harness/t/proverun.t
ext/Test-Harness/t/regression.t
ext/Test-Harness/t/taint.t

index 68d8b89..94d9852 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1187,10 +1187,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
@@ -1240,12 +1244,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
@@ -1267,6 +1274,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
index 4ae9f1d..44c04bd 100644 (file)
@@ -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.
index 01df160..cde1b9b 100644 (file)
@@ -259,6 +259,32 @@ names of any directories found in C<PERL5LIB> as -I switches. The net
 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
index 29d2f8f..bc665fa 100644 (file)
@@ -11,19 +11,17 @@ use Getopt::Long;
 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
 
@@ -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<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');
@@ -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<run>.
 
 =item C<state>
 
+=item C<state_class>
+
 =item C<taint_fail>
 
 =item C<taint_warn>
@@ -690,3 +688,88 @@ calling C<run>.
 =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
index 2b284d2..6eef184 100644 (file)
@@ -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<prove> 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<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:
@@ -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<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
@@ -107,7 +126,7 @@ Get the results of the last test run.  Returns a C<result_class()> instance.
 
 sub results {
     my $self = shift;
-    $self->{_} || $self->result_class->new 
+    $self->{_} || $self->result_class->new;
 }
 
 =head2 C<commit>
@@ -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;
 }
index 37337ea..a087da4 100644 (file)
@@ -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;
     }
index 50e2096..4744086 100644 (file)
@@ -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<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;
 }
 
index 25d4ce2..762d93d 100644 (file)
@@ -9,15 +9,16 @@ use TAP::Object;
 
 =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;
 
@@ -51,17 +52,8 @@ C<TAP::Base> provides callback management.
 
 =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 ) = @_;
 
diff --git a/ext/Test-Harness/lib/TAP/Formatter/Base.pm b/ext/Test-Harness/lib/TAP/Formatter/Base.pm
new file mode 100644 (file)
index 0000000..704cfad
--- /dev/null
@@ -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<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;
index 8558854..36a5b16 100644 (file)
@@ -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
 
index beacf9f..71cad30 100644 (file)
@@ -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<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
 
@@ -268,132 +59,6 @@ sub open_test {
     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 ) = @_;
@@ -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;
index eae6598..dcee635 100644 (file)
@@ -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<result>
@@ -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};
     }
index 074407b..129f388 100644 (file)
@@ -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<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 {
@@ -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 (file)
index 0000000..142fbc9
--- /dev/null
@@ -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<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;
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 (file)
index 0000000..1448770
--- /dev/null
@@ -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<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;
diff --git a/ext/Test-Harness/lib/TAP/Formatter/Session.pm b/ext/Test-Harness/lib/TAP/Formatter/Session.pm
new file mode 100644 (file)
index 0000000..a68e2a0
--- /dev/null
@@ -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<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;
index 27961cc..1512969 100644 (file)
@@ -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<TAP::Parser::Aggregator>.
 =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>
 
@@ -347,6 +348,9 @@ Any keys for which the value is C<undef> 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<make_scheduler>
@@ -674,10 +672,9 @@ sub 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>
 
index bbc7bfd..b57d32e 100644 (file)
@@ -9,11 +9,11 @@ TAP::Object - Base class that provides common functionality to all C<TAP::*> 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<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;
 
index c02f2ac..2393418 100644 (file)
@@ -14,19 +14,17 @@ use TAP::Parser::IteratorFactory ();
 
 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;
@@ -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
index d6fad64..2adc6e5 100644 (file)
@@ -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<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
 
@@ -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<any> of the parsers failed.  This includes:
 
 =item * Failed tests
 
-=item * Parse erros
+=item * Parse errors
 
 =item * Bad exit or wait status
 
index a644b07..7ea1d03 100644 (file)
@@ -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
 
index d33a963..b66e2e1 100644 (file)
@@ -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
 
index 4495bb8..9d7e2c2 100644 (file)
@@ -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
 
index cc9786c..027de0c 100644 (file)
@@ -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
 
index e71dfc4..3ed2534 100644 (file)
@@ -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
 
index 7aa4e4d..5186df1 100644 (file)
@@ -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
 
index 2efeb30..94761bc 100644 (file)
@@ -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
 
index 486c6ff..8e3497b 100644 (file)
@@ -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;
 }
index a4c9bbd..f80ea29 100644 (file)
@@ -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
 
index 04a2ce0..d07e1d2 100644 (file)
@@ -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
 
index 3225586..a577212 100644 (file)
@@ -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
 
index b0ea82a..df7a4fd 100644 (file)
@@ -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
 
index 4c12f61..7431769 100644 (file)
@@ -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
 
index 0316fb0..f0ed6e3 100644 (file)
@@ -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
 
index 3688f2b..d666091 100644 (file)
@@ -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
 
index d1e9cf6..0dcc95b 100644 (file)
@@ -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
 
index 5d33935..10deb63 100644 (file)
@@ -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
 
index c90432e..0320d19 100644 (file)
@@ -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<get_job>
@@ -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;
         }
index fe55faf..8003fc0 100644 (file)
@@ -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
 
index 25f1b4a..53cfc92 100644 (file)
@@ -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
 
index 3b10482..c04adcf 100644 (file)
@@ -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
 
index 444b429..2a2586e 100644 (file)
@@ -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;
index 85174c0..8aabd21 100644 (file)
@@ -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
 
index cc39350..9eba0c3 100644 (file)
@@ -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
 
index 98301a3..6c2e636 100644 (file)
@@ -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
 
index 24566ba..5a7a5ea 100644 (file)
@@ -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;
     }
 }
index b3aff2a..c8e32a1 100644 (file)
@@ -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';
 
index b442567..d199b7b 100644 (file)
@@ -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;
index ffa5370..c0d62b0 100644 (file)
@@ -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 (file)
index 0000000..68ad045
--- /dev/null
@@ -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 (file)
index 0000000..0ee8a79
--- /dev/null
@@ -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
+
index aa236df..c9f835a 100644 (file)
@@ -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',
index b24fc37..c82387b 100644 (file)
@@ -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;
index 7e285bd..81f79ea 100644 (file)
@@ -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 (file)
index 0000000..ae80003
--- /dev/null
@@ -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;
index 31648da..4bcaba3 100755 (executable)
@@ -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 (file)
index 0000000..c26fd2f
--- /dev/null
@@ -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;
index 20e540d..f8ce128 100644 (file)
@@ -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     => {
index f0e9ae2..0971684 100644 (file)
@@ -31,7 +31,7 @@ BEGIN {
         },
     );
     foreach my $test (@tests) {
-        
+
         # let's fully expand that filename
         $test->{file} = File::Spec->catfile(
             (   $ENV{PERL_CORE}
index 8fc312d..28baee4 100644 (file)
@@ -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 => [
index 91335ac..151ac6f 100644 (file)
@@ -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