This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Test::Harness 3.13
authorNicholas Clark <nick@ccl4.org>
Thu, 31 Jul 2008 21:27:36 +0000 (21:27 +0000)
committerNicholas Clark <nick@ccl4.org>
Thu, 31 Jul 2008 21:27:36 +0000 (21:27 +0000)
p4raw-id: //depot/perl@34169

83 files changed:
MANIFEST
lib/App/Prove.pm
lib/App/Prove/State.pm
lib/TAP/Base.pm
lib/TAP/Formatter/Color.pm
lib/TAP/Formatter/Console.pm
lib/TAP/Formatter/Console/ParallelSession.pm
lib/TAP/Formatter/Console/Session.pm
lib/TAP/Harness.pm
lib/TAP/Object.pm [new file with mode: 0644]
lib/TAP/Parser.pm
lib/TAP/Parser/Aggregator.pm
lib/TAP/Parser/Grammar.pm
lib/TAP/Parser/Iterator.pm
lib/TAP/Parser/Iterator/Array.pm
lib/TAP/Parser/Iterator/Process.pm
lib/TAP/Parser/Iterator/Stream.pm
lib/TAP/Parser/IteratorFactory.pm [new file with mode: 0644]
lib/TAP/Parser/Multiplexer.pm
lib/TAP/Parser/Result.pm
lib/TAP/Parser/Result/Bailout.pm
lib/TAP/Parser/Result/Comment.pm
lib/TAP/Parser/Result/Plan.pm
lib/TAP/Parser/Result/Pragma.pm
lib/TAP/Parser/Result/Test.pm
lib/TAP/Parser/Result/Unknown.pm
lib/TAP/Parser/Result/Version.pm
lib/TAP/Parser/Result/YAML.pm
lib/TAP/Parser/ResultFactory.pm [new file with mode: 0644]
lib/TAP/Parser/Scheduler.pm [new file with mode: 0644]
lib/TAP/Parser/Scheduler/Job.pm [new file with mode: 0644]
lib/TAP/Parser/Scheduler/Spinner.pm [new file with mode: 0644]
lib/TAP/Parser/Source.pm
lib/TAP/Parser/Source/Perl.pm
lib/TAP/Parser/Utils.pm
lib/TAP/Parser/YAMLish/Reader.pm
lib/TAP/Parser/YAMLish/Writer.pm
lib/Test/Harness.pm
lib/Test/Harness/Changes
lib/Test/Harness/bin/prove
lib/Test/Harness/t/000-load.t
lib/Test/Harness/t/aggregator.t
lib/Test/Harness/t/base.t
lib/Test/Harness/t/callbacks.t
lib/Test/Harness/t/compat/inc-propagation.t
lib/Test/Harness/t/compat/inc_taint.t
lib/Test/Harness/t/compat/regression.t
lib/Test/Harness/t/compat/test-harness-compat.t
lib/Test/Harness/t/grammar.t
lib/Test/Harness/t/harness.t
lib/Test/Harness/t/iterators.t
lib/Test/Harness/t/multiplexer.t
lib/Test/Harness/t/object.t [new file with mode: 0644]
lib/Test/Harness/t/parse.t
lib/Test/Harness/t/parser-config.t [new file with mode: 0644]
lib/Test/Harness/t/parser-subclass.t [new file with mode: 0644]
lib/Test/Harness/t/premature-bailout.t
lib/Test/Harness/t/process.t
lib/Test/Harness/t/prove.t
lib/Test/Harness/t/proveenv.t [new file with mode: 0644]
lib/Test/Harness/t/proverun.t
lib/Test/Harness/t/regression.t
lib/Test/Harness/t/results.t
lib/Test/Harness/t/scheduler.t [new file with mode: 0644]
lib/Test/Harness/t/source.t
lib/Test/Harness/t/spool.t
lib/Test/Harness/t/streams.t
lib/Test/Harness/t/testargs.t
lib/Test/Harness/t/unicode.t
lib/Test/Harness/t/yamlish.t
t/lib/App/Prove/Plugin/Dummy.pm
t/lib/EmptyParser.pm [new file with mode: 0644]
t/lib/MyCustom.pm [new file with mode: 0644]
t/lib/MyGrammar.pm [new file with mode: 0644]
t/lib/MyIterator.pm [new file with mode: 0644]
t/lib/MyIteratorFactory.pm [new file with mode: 0644]
t/lib/MyPerlSource.pm [new file with mode: 0644]
t/lib/MyResult.pm [new file with mode: 0644]
t/lib/MyResultFactory.pm [new file with mode: 0644]
t/lib/MySource.pm [new file with mode: 0644]
t/lib/TAP/Parser/SubclassTest.pm [new file with mode: 0644]
t/lib/subclass_tests/non_perl_source [new file with mode: 0644]
t/lib/subclass_tests/perl_source [new file with mode: 0644]

index ed17b84..bf648ec 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -2644,9 +2644,11 @@ lib/TAP/Formatter/Console/ParallelSession.pm     A parser for Test Anything Protocol
 lib/TAP/Formatter/Console.pm           A parser for Test Anything Protocol
 lib/TAP/Formatter/Console/Session.pm   A parser for Test Anything Protocol
 lib/TAP/Harness.pm                     A parser for Test Anything Protocol
+lib/TAP/Object.pm                      A parser for Test Anything Protocol
 lib/TAP/Parser/Aggregator.pm           A parser for Test Anything Protocol
 lib/TAP/Parser/Grammar.pm              A parser for Test Anything Protocol
 lib/TAP/Parser/Iterator/Array.pm       A parser for Test Anything Protocol
+lib/TAP/Parser/IteratorFactory.pm      A parser for Test Anything Protocol
 lib/TAP/Parser/Iterator.pm             A parser for Test Anything Protocol
 lib/TAP/Parser/Iterator/Process.pm     A parser for Test Anything Protocol
 lib/TAP/Parser/Iterator/Stream.pm      A parser for Test Anything Protocol
@@ -2654,6 +2656,7 @@ lib/TAP/Parser/Multiplexer.pm             A parser for Test Anything Protocol
 lib/TAP/Parser.pm                      A parser for Test Anything Protocol
 lib/TAP/Parser/Result/Bailout.pm       A parser for Test Anything Protocol
 lib/TAP/Parser/Result/Comment.pm       A parser for Test Anything Protocol
+lib/TAP/Parser/ResultFactory.pm                A parser for Test Anything Protocol
 lib/TAP/Parser/Result/Plan.pm          A parser for Test Anything Protocol
 lib/TAP/Parser/Result.pm               A parser for Test Anything Protocol
 lib/TAP/Parser/Result/Pragma.pm                A parser for Test Anything Protocol
@@ -2661,6 +2664,9 @@ lib/TAP/Parser/Result/Test.pm             A parser for Test Anything Protocol
 lib/TAP/Parser/Result/Unknown.pm       A parser for Test Anything Protocol
 lib/TAP/Parser/Result/Version.pm       A parser for Test Anything Protocol
 lib/TAP/Parser/Result/YAML.pm          A parser for Test Anything Protocol
+lib/TAP/Parser/Scheduler/Job.pm                A parser for Test Anything Protocol
+lib/TAP/Parser/Scheduler.pm            A parser for Test Anything Protocol
+lib/TAP/Parser/Scheduler/Spinner.pm    A parser for Test Anything Protocol
 lib/TAP/Parser/Source/Perl.pm          A parser for Test Anything Protocol
 lib/TAP/Parser/Source.pm               A parser for Test Anything Protocol
 lib/TAP/Parser/Utils.pm                        A parser for Test Anything Protocol
@@ -2710,14 +2716,19 @@ lib/Test/Harness/t/iterators.t          Test::Harness test
 lib/Test/Harness/t/multiplexer.t       Test::Harness test
 lib/Test/Harness/t/nofork-mux.t                Test::Harness test
 lib/Test/Harness/t/nofork.t            Test::Harness test
+lib/Test/Harness/t/object.t            Test::Harness test
+lib/Test/Harness/t/parser-config.t     Test::Harness test
+lib/Test/Harness/t/parser-subclass.t   Test::Harness test
 lib/Test/Harness/t/parse.t             Test::Harness test
 lib/Test/Harness/t/premature-bailout.t Test::Harness test
 lib/Test/Harness/t/process.t           Test::Harness test
+lib/Test/Harness/t/proveenv.t          Test::Harness test
 lib/Test/Harness/t/proverc.t           Test::Harness test
 lib/Test/Harness/t/proverun.t          Test::Harness test
 lib/Test/Harness/t/prove.t             Test::Harness test
 lib/Test/Harness/t/regression.t                Test::Harness test
 lib/Test/Harness/t/results.t           Test::Harness test
+lib/Test/Harness/t/scheduler.t         Test::Harness test
 lib/Test/Harness/t/source.t            Test::Harness test
 lib/Test/Harness/t/spool.t             Test::Harness test
 lib/Test/Harness/t/state.t             Test::Harness test
@@ -3610,6 +3621,7 @@ t/lib/dprof/test7_v               Perl code profiler tests
 t/lib/dprof/test8_t            Perl code profiler tests
 t/lib/dprof/test8_v            Perl code profiler tests
 t/lib/dprof/V.pm               Perl code profiler tests
+t/lib/EmptyParser.pm           Module for testing Test::Harness
 t/lib/feature/bundle           Tests for feature bundles
 t/lib/feature/implicit         Tests for implicit loading of feature.pm
 t/lib/feature/nonesuch         Tests for enabling/disabling nonexistent feature
@@ -3637,8 +3649,16 @@ t/lib/Math/BigInt/BareCalc.pm    Bigint's simulation of Calc
 t/lib/Math/BigInt/Scalar.pm    Pure Perl module to support Math::BigInt
 t/lib/Math/BigInt/Subclass.pm  Empty subclass of BigInt for test
 t/lib/Math/BigRat/Test.pm              Math::BigRat test helper
+t/lib/MyCustom.pm              Module for testing Test::Harness
+t/lib/MyGrammar.pm             Module for testing Test::Harness
+t/lib/MyIteratorFactory.pm     Module for testing Test::Harness
+t/lib/MyIterator.pm            Module for testing Test::Harness
+t/lib/MyPerlSource.pm          Module for testing Test::Harness
 t/lib/mypragma.pm              An example user pragma
 t/lib/mypragma.t               Test the example user pragma
+t/lib/MyResultFactory.pm       Module for testing Test::Harness
+t/lib/MyResult.pm              Module for testing Test::Harness
+t/lib/MySource.pm              Module for testing Test::Harness
 t/lib/NoFork.pm                        Module for testing Test::Harness
 t/lib/no_load.t                        Test that some modules don't load others
 t/lib/proxy_constant_subs.t    Test that Proxy Constant Subs behave correctly
@@ -3706,6 +3726,9 @@ t/lib/source_tests/source         Test data for Test::Harness
 t/lib/strict/refs              Tests of "use strict 'refs'" for strict.t
 t/lib/strict/subs              Tests of "use strict 'subs'" for strict.t
 t/lib/strict/vars              Tests of "use strict 'vars'" for strict.t
+t/lib/subclass_tests/non_perl_source   Test data for Test::Harness
+t/lib/subclass_tests/perl_source       Test data for Test::Harness
+t/lib/TAP/Parser/SubclassTest.pm       Module for testing Test::Harness
 t/lib/Test/Simple/Catch.pm     Utility module for testing Test::Simple
 t/lib/Test/Simple/sample_tests/death_in_eval.plx       for exit.t
 t/lib/Test/Simple/sample_tests/death.plx               for exit.t
index a4ea539..b68ca40 100644 (file)
@@ -1,6 +1,9 @@
 package App::Prove;
 
 use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
 use TAP::Harness;
 use TAP::Parser::Utils qw( split_shell );
 use File::Spec;
@@ -8,7 +11,7 @@ use Getopt::Long;
 use App::Prove::State;
 use Carp;
 
-use vars qw($VERSION);
+@ISA = qw(TAP::Object);
 
 =head1 NAME
 
@@ -16,11 +19,11 @@ App::Prove - Implements the C<prove> command.
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
@@ -55,7 +58,7 @@ BEGIN {
       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
+      show_version test_args state dry extension ignore_exit rules
     );
     for my $attr (@ATTR) {
         no strict 'refs';
@@ -78,20 +81,18 @@ initializers may be passed.
 
 =cut
 
-sub new {
-    my $class = shift;
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+    my $self = shift;
     my $args = shift || {};
 
-    my $self = bless {
-        argv          => [],
-        rc_opts       => [],
-        includes      => [],
-        modules       => [],
-        state         => [],
-        plugins       => [],
-        harness_class => 'TAP::Harness',
-        _state        => App::Prove::State->new( { store => STATE_FILE } ),
-    }, $class;
+    # setup defaults:
+    for my $key (qw( argv rc_opts includes modules state plugins rules )) {
+        $self->{$key} = [];
+    }
+    $self->{harness_class} = 'TAP::Harness';
+    $self->{_state} = App::Prove::State->new( { store => STATE_FILE } );
 
     for my $attr (@ATTR) {
         if ( exists $args->{$attr} ) {
@@ -100,6 +101,15 @@ sub new {
             $self->{$attr} = $args->{$attr};
         }
     }
+
+    my %env_provides_default = (
+        HARNESS_TIMER => 'timer',
+    );
+
+    while ( my ( $env, $attr ) = each %env_provides_default ) {
+        $self->{$attr} = 1 if $ENV{$env};
+    }
+
     return $self;
 }
 
@@ -194,7 +204,9 @@ sub process_args {
             'colour!'     => \$self->{color},
             'c'           => \$self->{color},
             'D|dry'       => \$self->{dry},
+            'ext=s'       => \$self->{extension},
             'harness=s'   => \$self->{harness},
+            'ignore-exit' => \$self->{ignore_exit},
             'formatter=s' => \$self->{formatter},
             'r|recurse'   => \$self->{recurse},
             'reverse'     => \$self->{backwards},
@@ -219,6 +231,7 @@ sub process_args {
             't'           => \$self->{taint_warn},
             'W'           => \$self->{warnings_fail},
             'w'           => \$self->{warnings_warn},
+            'rules=s@'    => $self->{rules},
         ) or croak('Unable to continue');
 
         # Stash the remainder of argv for later
@@ -236,8 +249,6 @@ sub _first_pos {
     return;
 }
 
-sub _exit { exit( $_[1] || 0 ) }
-
 sub _help {
     my ( $self, $verbosity ) = @_;
 
@@ -289,6 +300,10 @@ sub _get_args {
         $args{formatter_class} = $formatter;
     }
 
+    if ( $self->ignore_exit ) {
+        $args{ignore_exit} = 1;
+    }
+
     if ( $self->taint_fail && $self->taint_warn ) {
         die '-t and -T are mutually exclusive';
     }
@@ -328,6 +343,19 @@ sub _get_args {
         $args{test_args} = $test_args;
     }
 
+    if ( @{ $self->rules } ) {
+        my @rules;
+        for ( @{ $self->rules } ) {
+            if (/^par=(.*)/) {
+                push @rules, $1;
+            }
+            elsif (/^seq=(.*)/) {
+                push @rules, { seq => $1 };
+            }
+        }
+        $args{rules} = { par => [@rules] };
+    }
+
     return ( \%args, $self->{harness_class} );
 }
 
@@ -406,16 +434,18 @@ sub run {
 
         local $ENV{TEST_VERBOSE} = 1 if $self->verbose;
 
-        $self->_runtests( $self->_get_args, $self->_get_tests );
+        return $self->_runtests( $self->_get_args, $self->_get_tests );
     }
 
-    return;
+    return 1;
 }
 
 sub _get_tests {
     my $self = shift;
 
     my $state = $self->{_state};
+    my $ext   = $self->extension;
+    $state->extension($ext) if defined $ext;
     if ( defined( my $state_switch = $self->state ) ) {
         $state->apply_switch(@$state_switch);
     }
@@ -440,9 +470,7 @@ sub _runtests {
 
     my $aggregator = $harness->runtests(@tests);
 
-    $self->_exit( $aggregator->has_problems ? 1 : 0 );
-
-    return;
+    return $aggregator->has_problems ? 0 : 1;
 }
 
 sub _get_switches {
@@ -511,10 +539,15 @@ Load a harness replacement class.
 sub require_harness {
     my ( $self, $for, $class ) = @_;
 
-    eval("require $class");
-    die "$class is required to use the --$for feature: $@" if $@;
+    my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/;
 
-    $self->{harness_class} = $class;
+    # Emulate Perl's -MModule=arg1,arg2 behaviour
+    $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!;
+
+    eval("use $class;");
+    die "$class_name is required to use the --$for feature: $@" if $@;
+
+    $self->{harness_class} = $class_name;
 
     return;
 }
@@ -566,6 +599,8 @@ calling C<run>.
 
 =item C<exec>
 
+=item C<extension>
+
 =item C<failures>
 
 =item C<fork>
@@ -574,6 +609,8 @@ calling C<run>.
 
 =item C<harness>
 
+=item C<ignore_exit>
+
 =item C<includes>
 
 =item C<jobs>
@@ -594,6 +631,8 @@ calling C<run>.
 
 =item C<recurse>
 
+=item C<rules>
+
 =item C<show_help>
 
 =item C<show_man>
index dbc73f4..aeac643 100644 (file)
@@ -1,6 +1,8 @@
 package App::Prove::State;
 
 use strict;
+use vars qw($VERSION @ISA);
+
 use File::Find;
 use File::Spec;
 use Carp;
@@ -8,7 +10,6 @@ use TAP::Parser::YAMLish::Reader ();
 use TAP::Parser::YAMLish::Writer ();
 use TAP::Base;
 
-use vars qw($VERSION @ISA);
 @ISA = qw( TAP::Base );
 
 use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
@@ -20,11 +21,11 @@ App::Prove::State - State storage for the C<prove> command.
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
@@ -47,6 +48,7 @@ and the operations that may be performed on it.
 
 =cut
 
+# override TAP::Base::new:
 sub new {
     my $class = shift;
     my %args = %{ shift || {} };
@@ -56,9 +58,10 @@ sub new {
             tests      => {},
             generation => 1
         },
-        select => [],
-        seq    => 1,
-        store  => delete $args{store},
+        select    => [],
+        seq       => 1,
+        store     => delete $args{store},
+        extension => delete $args{extension} || '.t',
     }, $class;
 
     my $store = $self->{store};
@@ -68,6 +71,19 @@ sub new {
     return $self;
 }
 
+=head2 C<extension>
+
+Get or set the extension files must have in order to be considered
+tests. Defaults to '.t'.
+
+=cut
+
+sub extension {
+    my $self = shift;
+    $self->{extension} = shift if @_;
+    return $self->{extension};
+}
+
 sub DESTROY {
     my $self = shift;
     if ( $self->{should_save} && defined( my $store = $self->{store} ) ) {
@@ -222,9 +238,9 @@ sub get_tests {
     my @selected = $self->_query;
 
     unless ( @argv || @{ $self->{select} } ) {
-        croak q{No tests named and 't' directory not found}
-          unless -d 't';
-        @argv = 't';
+        @argv = $recurse ? '.' : 't';
+        croak qq{No tests named and '@argv' directory not found}
+          unless -d $argv[0];
     }
 
     push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv;
@@ -278,6 +294,7 @@ sub _get_raw_tests {
 
     # Do globbing on Win32.
     @argv = map { glob "$_" } @argv if NEED_GLOB;
+    my $extension = $self->{extension};
 
     for my $arg (@argv) {
         if ( '-' eq $arg ) {
@@ -289,22 +306,22 @@ sub _get_raw_tests {
         push @tests,
             sort -d $arg
           ? $recurse
-              ? $self->_expand_dir_recursive($arg)
-              : glob( File::Spec->catfile( $arg, '*.t' ) )
+              ? $self->_expand_dir_recursive( $arg, $extension )
+              : glob( File::Spec->catfile( $arg, "*$extension" ) )
           : $arg;
     }
     return @tests;
 }
 
 sub _expand_dir_recursive {
-    my ( $self, $dir ) = @_;
+    my ( $self, $dir, $extension ) = @_;
 
     my @tests;
     find(
         {   follow => 1,      #21938
             wanted => sub {
                 -f 
-                  && /\.t$/
+                  && /\Q$extension\E$/
                   && push @tests => $File::Find::name;
               }
         },
index fc541c3..0745034 100644 (file)
@@ -1,7 +1,11 @@
 package TAP::Base;
 
 use strict;
-use vars qw($VERSION);
+use vars qw($VERSION @ISA);
+
+use TAP::Object;
+
+@ISA = qw(TAP::Object);
 
 =head1 NAME
 
@@ -9,11 +13,11 @@ TAP::Base - Base class that provides common functionality to L<TAP::Parser> and
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 my $GOT_TIME_HIRES;
 
@@ -116,14 +120,6 @@ sub _make_callback {
     return map { $_->(@_) } @$cb;
 }
 
-sub _croak {
-    my ( $self, $message ) = @_;
-    require Carp;
-    Carp::croak($message);
-
-    return;
-}
-
 =head3 C<get_time>
 
 Return the current time using Time::HiRes if available.
index a1fbf1c..532f279 100644 (file)
@@ -1,11 +1,12 @@
 package TAP::Formatter::Color;
 
 use strict;
-
-use vars qw($VERSION);
+use vars qw($VERSION @ISA);
 
 use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
 
+@ISA = qw(TAP::Object);
+
 my $NO_COLOR;
 
 BEGIN {
@@ -70,11 +71,11 @@ TAP::Formatter::Color - Run Perl test scripts with color
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
@@ -106,18 +107,20 @@ L<Term::ANSIColor> is not installed, returns undef.
 
 =cut
 
-sub new {
-    my $class = shift;
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+    my $self = shift;
 
     if ($NO_COLOR) {
 
         # shorten that message a bit
         ( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s;
         warn "Note: Cannot run tests in color: $error\n";
-        return;
+        return;    # abort object construction
     }
 
-    return bless {}, $class;
+    return $self;
 }
 
 ##############################################################################
index fd54af2..05384f0 100644 (file)
@@ -31,7 +31,6 @@ BEGIN {
 
     my @getter_setters = qw(
       _longest
-      _tests_without_extensions
       _printed_summary_header
       _colorizer
     );
@@ -52,11 +51,11 @@ TAP::Formatter::Console - Harness output delegate for default console output
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
@@ -192,6 +191,9 @@ Any keys for which the value is C<undef> will be ignored.
 
 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 {
@@ -199,17 +201,10 @@ sub prepare {
 
     my $longest = 0;
 
-    my $tests_without_extensions = 0;
     foreach my $test (@tests) {
         $longest = length $test if length $test > $longest;
-        if ( $test !~ /\.\w+$/ ) {
-
-            # TODO: Coverage?
-            $tests_without_extensions = 1;
-        }
     }
 
-    $self->_tests_without_extensions($tests_without_extensions);
     $self->_longest($longest);
 }
 
@@ -217,13 +212,8 @@ sub _format_now { strftime "[%H:%M:%S]", localtime }
 
 sub _format_name {
     my ( $self, $test ) = @_;
-    my $name  = $test;
-    my $extra = 0;
-    unless ( $self->_tests_without_extensions ) {
-        $name =~ s/(\.\w+)$//;    # strip the .t or .pm
-        $extra = length $1;
-    }
-    my $periods = '.' x ( $self->_longest + $extra + 4 - length $test );
+    my $name = $test;
+    my $periods = '.' x ( $self->_longest + 4 - length $test );
 
     if ( $self->timer ) {
         my $stamp = $self->_format_now();
index 32a3fb6..a509cf7 100644 (file)
@@ -48,11 +48,11 @@ TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
index 6bed3c0..0c14f00 100644 (file)
@@ -36,11 +36,11 @@ TAP::Formatter::Console::Session - Harness output delegate for default console o
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
@@ -227,6 +227,11 @@ sub _closures {
         },
 
         close_test => sub {
+
+            # Avoid circular references
+            $self->parser(undef);
+            $self->{_closures} = {};
+
             return if $really_quiet;
 
             if ($show_count) {
@@ -288,9 +293,6 @@ sub _output_test_failure {
     my $failed = $parser->failed + $total - $tests_run;
     my $exit   = $parser->exit;
 
-    # TODO: $flist isn't used anywhere
-    # my $flist  = join ", " => $formatter->range( $parser->failed );
-
     if ( my $exit = $parser->exit ) {
         my $wstat = $parser->wait;
         my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat );
index 28e6d3a..774152a 100644 (file)
@@ -11,6 +11,7 @@ use TAP::Base;
 use TAP::Parser;
 use TAP::Parser::Aggregator;
 use TAP::Parser::Multiplexer;
+use TAP::Parser::Scheduler;
 
 use vars qw($VERSION @ISA);
 
@@ -22,11 +23,11 @@ TAP::Harness - Run test scripts with statistics
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 $ENV{HARNESS_ACTIVE}  = 1;
 $ENV{HARNESS_VERSION} = $VERSION;
@@ -81,6 +82,8 @@ BEGIN {
         jobs            => sub { shift; shift },
         fork            => sub { shift; shift },
         test_args       => sub { shift; shift },
+        ignore_exit     => sub { shift; shift },
+        rules           => sub { shift; shift },
     );
 
     for my $method ( sort keys %VALIDATION_FOR ) {
@@ -185,7 +188,22 @@ TAP is fine.  You can use this argument to specify the name of the program
 (and optional switches) to run your tests with:
 
   exec => ['/usr/bin/ruby', '-w']
-  
+
+You can also pass a subroutine reference in order to determine and return the
+proper program to run based on a given test script. The subroutine reference
+should expect the TAP::Harness object itself as the first argument, and the
+file name as the second argument. It should return an array reference
+containing the command to be run and including the test file name. It can also
+simply return C<undef>, in which case TAP::Harness will fall back on executing
+the test script in Perl:
+
+  exec => sub {
+      my ( $harness, $test_file ) = @_;
+      # Let Perl tests run.
+      return undef if $test_file =~ /[.]t$/;
+      return [ qw( /usr/bin/ruby -w ), $test_file ] if $test_file =~ /[.]rb$/;
+  }
+
 =item * C<merge>
 
 If C<merge> is true the harness will create parsers that merge STDOUT
@@ -214,6 +232,28 @@ true:
 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<ignore_exit>
+
+If set to a true value instruct C<TAP::Parser> to ignore exit and wait
+status from test scripts.
+
+=item * C<rules>
+
+A reference to a hash of rules that control which tests may be
+executed in parallel. This is an experimental feature and the
+interface may change.
+
+    $harness->rules(
+        {   par => [
+                { seq => '../ext/DB_File/t/*' },
+                { seq => '../ext/IO_Compress_Zlib/t/*' },
+                { seq => '../lib/CPANPLUS/*' },
+                { seq => '../lib/ExtUtils/t/*' },
+                '*'
+            ]
+        }
+    );
+
 =item * C<stdout>
 
 A filehandle for catching standard output.
@@ -333,21 +373,32 @@ sub runtests {
     $aggregate->start;
     $self->aggregate_tests( $aggregate, @tests );
     $aggregate->stop;
-    $self->formatter->summary($aggregate);
+    $self->summary($aggregate);
     $self->_make_callback( 'after_runtests', $aggregate );
 
     return $aggregate;
 }
 
+=head3 C<summary>
+
+Output the summary for a TAP::Parser::Aggregator.
+
+=cut
+
+sub summary {
+    my ( $self, $aggregate ) = @_;
+    $self->formatter->summary($aggregate);
+}
+
 sub _after_test {
-    my ( $self, $aggregate, $test, $parser ) = @_;
+    my ( $self, $aggregate, $job, $parser ) = @_;
 
-    $self->_make_callback( 'after_test', $test, $parser );
-    $aggregate->add( $test->[1], $parser );
+    $self->_make_callback( 'after_test', $job->as_array_ref, $parser );
+    $aggregate->add( $job->description, $parser );
 }
 
 sub _aggregate_forked {
-    my ( $self, $aggregate, @tests ) = @_;
+    my ( $self, $aggregate, $scheduler ) = @_;
 
     eval { require Parallel::Iterator };
 
@@ -357,9 +408,11 @@ sub _aggregate_forked {
     my $iter = Parallel::Iterator::iterate(
         { workers => $self->jobs || 0 },
         sub {
-            my ( $id, $test ) = @_;
+            my $job = shift;
+
+            return if $job->is_spinner;
 
-            my ( $parser, $session ) = $self->make_parser($test);
+            my ( $parser, $session ) = $self->make_parser($job);
 
             while ( defined( my $result = $parser->next ) ) {
                 exit 1 if $result->is_bailout;
@@ -373,18 +426,20 @@ sub _aggregate_forked {
             delete $parser->{_grammar};
             return $parser;
         },
-        \@tests
+        sub { $scheduler->get_job }
     );
 
-    while ( my ( $id, $parser ) = $iter->() ) {
-        $self->_after_test( $aggregate, $tests[$id], $parser );
+    while ( my ( $job, $parser ) = $iter->() ) {
+        next if $job->is_spinner;
+        $self->_after_test( $aggregate, $job, $parser );
+        $job->finish;
     }
 
     return;
 }
 
 sub _aggregate_parallel {
-    my ( $self, $aggregate, @tests ) = @_;
+    my ( $self, $aggregate, $scheduler ) = @_;
 
     my $jobs = $self->jobs;
     my $mux  = TAP::Parser::Multiplexer->new;
@@ -392,14 +447,19 @@ sub _aggregate_parallel {
     RESULT: {
 
         # Keep multiplexer topped up
-        while ( @tests && $mux->parsers < $jobs ) {
-            my $test = shift @tests;
-            my ( $parser, $session ) = $self->make_parser($test);
-            $mux->add( $parser, [ $session, $test ] );
+        FILL:
+        while ( $mux->parsers < $jobs ) {
+            my $job = $scheduler->get_job;
+
+            # If we hit a spinner stop filling and start running.
+            last FILL if !defined $job || $job->is_spinner;
+
+            my ( $parser, $session ) = $self->make_parser($job);
+            $mux->add( $parser, [ $session, $job ] );
         }
 
         if ( my ( $parser, $stash, $result ) = $mux->next ) {
-            my ( $session, $test ) = @$stash;
+            my ( $session, $job ) = @$stash;
             if ( defined $result ) {
                 $session->result($result);
                 exit 1 if $result->is_bailout;
@@ -408,7 +468,8 @@ sub _aggregate_parallel {
 
                 # End of parser. Automatically removed from the mux.
                 $self->finish_parser( $parser, $session );
-                $self->_after_test( $aggregate, $test, $parser );
+                $self->_after_test( $aggregate, $job, $parser );
+                $job->finish;
             }
             redo RESULT;
         }
@@ -418,10 +479,13 @@ sub _aggregate_parallel {
 }
 
 sub _aggregate_single {
-    my ( $self, $aggregate, @tests ) = @_;
+    my ( $self, $aggregate, $scheduler ) = @_;
 
-    for my $test (@tests) {
-        my ( $parser, $session ) = $self->make_parser($test);
+    JOB:
+    while ( my $job = $scheduler->get_job ) {
+        next JOB if $job->is_spinner;
+
+        my ( $parser, $session ) = $self->make_parser($job);
 
         while ( defined( my $result = $parser->next ) ) {
             $session->result($result);
@@ -435,7 +499,8 @@ sub _aggregate_single {
         }
 
         $self->finish_parser( $parser, $session );
-        $self->_after_test( $aggregate, $test, $parser );
+        $self->_after_test( $aggregate, $job, $parser );
+        $job->finish;
     }
 
     return;
@@ -477,7 +542,7 @@ Each elements of the @tests array is either
 
 =item * the file name of a test script to run
 
-=item * a reference to a [ file name, display name ]
+=item * a reference to a [ file name, display name ] array
 
 =back
 
@@ -492,32 +557,70 @@ different name.
 sub aggregate_tests {
     my ( $self, $aggregate, @tests ) = @_;
 
-    my $jobs = $self->jobs;
-
-    my @expanded = map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @tests;
+    my $jobs      = $self->jobs;
+    my $scheduler = $self->make_scheduler(@tests);
 
     # #12458
     local $ENV{HARNESS_IS_VERBOSE} = 1
       if $self->formatter->verbosity > 0;
 
-    # Formatter gets only names
-    $self->formatter->prepare( map { $_->[1] } @expanded );
+    # Formatter gets only names.
+    $self->formatter->prepare( map { $_->description } $scheduler->get_all );
 
     if ( $self->jobs > 1 ) {
         if ( $self->fork ) {
-            $self->_aggregate_forked( $aggregate, @expanded );
+            $self->_aggregate_forked( $aggregate, $scheduler );
         }
         else {
-            $self->_aggregate_parallel( $aggregate, @expanded );
+            $self->_aggregate_parallel( $aggregate, $scheduler );
         }
     }
     else {
-        $self->_aggregate_single( $aggregate, @expanded );
+        $self->_aggregate_single( $aggregate, $scheduler );
     }
 
     return;
 }
 
+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;
+}
+
+=head3 C<make_scheduler>
+
+Called by the harness when it needs to create a
+L<TAP::Parser::Scheduler>. Override in a subclass to provide an
+alternative scheduler. C<make_scheduler> is passed the list of tests
+that was passed to C<aggregate_tests>.
+
+=cut
+
+sub make_scheduler {
+    my ( $self, @tests ) = @_;
+    return TAP::Parser::Scheduler->new(
+        tests => [ $self->_add_descriptions(@tests) ],
+        rules => $self->rules
+    );
+}
+
 =head3 C<jobs>
 
 Returns the number of concurrent test runs the harness is handling. For the default
@@ -582,19 +685,23 @@ This is a bit clunky and will be cleaned up in a later release.
 =cut
 
 sub _get_parser_args {
-    my ( $self, $test ) = @_;
-    my $test_prog = $test->[0];
+    my ( $self, $job ) = @_;
+    my $test_prog = $job->filename;
     my %args      = ();
     my @switches;
     @switches = $self->lib if $self->lib;
     push @switches => $self->switches if $self->switches;
-    $args{switches} = \@switches;
-    $args{spool}    = $self->_open_spool($test_prog);
-    $args{merge}    = $self->merge;
-    $args{exec}     = $self->exec;
+    $args{switches}    = \@switches;
+    $args{spool}       = $self->_open_spool($test_prog);
+    $args{merge}       = $self->merge;
+    $args{ignore_exit} = $self->ignore_exit;
 
     if ( my $exec = $self->exec ) {
-        $args{exec} = [ @$exec, $test_prog ];
+        $args{exec}
+          = ref $exec eq 'CODE'
+          ? $exec->( $self, $test_prog )
+          : [ @$exec, $test_prog ];
+        $args{source} = $test_prog unless $args{exec};
     }
     else {
         $args{source} = $test_prog;
@@ -618,14 +725,14 @@ overridden in subclasses.
 =cut
 
 sub make_parser {
-    my ( $self, $test ) = @_;
+    my ( $self, $job ) = @_;
 
-    my $args = $self->_get_parser_args($test);
-    $self->_make_callback( 'parser_args', $args, $test );
+    my $args = $self->_get_parser_args($job);
+    $self->_make_callback( 'parser_args', $args, $job->as_array_ref );
     my $parser = TAP::Parser->new($args);
 
-    $self->_make_callback( 'made_parser', $parser, $test );
-    my $session = $self->formatter->open_test( $test->[1], $parser );
+    $self->_make_callback( 'made_parser', $parser, $job->as_array_ref );
+    my $session = $self->formatter->open_test( $job->description, $parser );
 
     return ( $parser, $session );
 }
diff --git a/lib/TAP/Object.pm b/lib/TAP/Object.pm
new file mode 100644 (file)
index 0000000..71a0a88
--- /dev/null
@@ -0,0 +1,97 @@
+package TAP::Object;
+
+use strict;
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Object - Base class that provides common functionality to all C<TAP::*> modules
+
+=head1 VERSION
+
+Version 3.13
+
+=cut
+
+$VERSION = '3.13';
+
+=head1 SYNOPSIS
+
+    package TAP::Whatever;
+
+    use strict;
+    use vars qw(@ISA);
+
+    use TAP::Object;
+
+    @ISA = qw(TAP::Object);
+
+    # new() implementation by TAP::Object
+    sub _initialize {
+        my ( $self, @args) = @_;
+        # initialize your object
+        return $self;
+    }
+
+    # ... later ...
+    my $obj = TAP::Whatever->new(@args);
+
+=head1 DESCRIPTION
+
+C<TAP::Object> provides a default constructor and exception model for all
+C<TAP::*> classes.  Exceptions are raised using L<Carp>.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create a new object.  Any arguments passed to C<new> will be passed on to the
+L</_initialize> method.  Returns a new object.
+
+=cut
+
+sub new {
+    my $class = shift;
+    my $self = bless {}, $class;
+    return $self->_initialize(@_);
+}
+
+=head2 Instance Methods
+
+=head3 C<_initialize>
+
+Initializes a new object.  This method is a stub by default, you should override
+it as appropriate.
+
+I<Note:> L</new> expects you to return C<$self> or raise an exception.  See
+L</_croak>, and L<Carp>.
+
+=cut
+
+sub _initialize {
+    return $_[0];
+}
+
+=head3 C<_croak>
+
+Raise an exception using C<croak> from L<Carp>, eg:
+
+    $self->_croak( 'why me?', 'aaarrgh!' );
+
+May also be called as a I<class> method.
+
+    $class->_croak( 'this works too' );
+
+=cut
+
+sub _croak {
+    my $proto = shift;
+    require Carp;
+    Carp::croak(@_);
+    return;
+}
+
+1;
+
index 2c59741..62a8b51 100644 (file)
@@ -3,12 +3,14 @@ package TAP::Parser;
 use strict;
 use vars qw($VERSION @ISA);
 
-use TAP::Base                 ();
-use TAP::Parser::Grammar      ();
-use TAP::Parser::Result       ();
-use TAP::Parser::Source       ();
-use TAP::Parser::Source::Perl ();
-use TAP::Parser::Iterator     ();
+use TAP::Base                    ();
+use TAP::Parser::Grammar         ();
+use TAP::Parser::Result          ();
+use TAP::Parser::ResultFactory   ();
+use TAP::Parser::Source          ();
+use TAP::Parser::Source::Perl    ();
+use TAP::Parser::Iterator        ();
+use TAP::Parser::IteratorFactory ();
 
 use Carp qw( confess );
 
@@ -20,11 +22,11 @@ TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 my $DEFAULT_TAP_VERSION = 12;
 my $MAX_TAP_VERSION     = 13;
@@ -42,7 +44,6 @@ BEGIN {    # making accessors
         qw(
         _stream
         _spool
-        _grammar
         exec
         exit
         is_good_plan
@@ -55,32 +56,20 @@ BEGIN {    # making accessors
         start_time
         end_time
         skip_all
+        source_class
+        perl_source_class
+        grammar_class
+        iterator_factory_class
+        result_factory_class
         )
       )
     {
         no strict 'refs';
-
-        # another tiny performance hack
-        if ( $method =~ /^_/ ) {
-            *$method = sub {
-                my $self = shift;
-                return $self->{$method} unless @_;
-
-                # Trusted methods
-                unless ( ( ref $self ) =~ /^TAP::Parser/ ) {
-                    Carp::croak("$method() may not be set externally");
-                }
-
-                $self->{$method} = shift;
-            };
-        }
-        else {
-            *$method = sub {
-                my $self = shift;
-                return $self->{$method} unless @_;
-                $self->{$method} = shift;
-            };
-        }
+        *$method = sub {
+            my $self = shift;
+            return $self->{$method} unless @_;
+            $self->{$method} = shift;
+        };
     }
 }    # done making accessors
 
@@ -220,11 +209,55 @@ allow exact synchronization.
 Subtleties of this behavior may be platform-dependent and may change in
 the future.
 
+=item * C<source_class>
+
+This option was introduced to let you easily customize which I<source> class
+the parser should use.  It defaults to L<TAP::Parser::Source>.
+
+See also L</make_source>.
+
+=item * C<perl_source_class>
+
+This option was introduced to let you easily customize which I<perl source>
+class the parser should use.  It defaults to L<TAP::Parser::Source::Perl>.
+
+See also L</make_perl_source>.
+
+=item * C<grammar_class>
+
+This option was introduced to let you easily customize which I<grammar> class
+the parser should use.  It defaults to L<TAP::Parser::Grammar>.
+
+See also L</make_grammar>.
+
+=item * C<iterator_factory_class>
+
+This option was introduced to let you easily customize which I<iterator>
+factory class the parser should use.  It defaults to
+L<TAP::Parser::IteratorFactory>.
+
+See also L</make_iterator>.
+
+=item * C<result_factory_class>
+
+This option was introduced to let you easily customize which I<result>
+factory class the parser should use.  It defaults to
+L<TAP::Parser::ResultFactory>.
+
+See also L</make_result>.
+
 =back
 
 =cut
 
-# new implementation supplied by TAP::Base
+# new() implementation supplied by TAP::Base
+
+# This should make overriding behaviour of the Parser in subclasses easier:
+sub _default_source_class           {'TAP::Parser::Source'}
+sub _default_perl_source_class      {'TAP::Parser::Source::Perl'}
+sub _default_grammar_class          {'TAP::Parser::Grammar'}
+sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'}
+sub _default_result_factory_class   {'TAP::Parser::ResultFactory'}
 
 ##############################################################################
 
@@ -270,6 +303,68 @@ sub run {
     }
 }
 
+##############################################################################
+
+=head3 C<make_source>
+
+Make a new L<TAP::Parser::Source> object and return it.  Passes through any
+arguments given.
+
+The C<source_class> can be customized, as described in L</new>.
+
+=head3 C<make_perl_source>
+
+Make a new L<TAP::Parser::Source::Perl> object and return it.  Passes through
+any arguments given.
+
+The C<perl_source_class> can be customized, as described in L</new>.
+
+=head3 C<make_grammar>
+
+Make a new L<TAP::Parser::Grammar> object and return it.  Passes through any
+arguments given.
+
+The C<grammar_class> can be customized, as described in L</new>.
+
+=head3 C<make_iterator>
+
+Make a new L<TAP::Parser::Iterator> object using the parser's
+L<TAP::Parser::IteratorFactory>, and return it.  Passes through any arguments
+given.
+
+The C<iterator_factory_class> can be customized, as described in L</new>.
+
+=head3 C<make_result>
+
+Make a new L<TAP::Parser::Result> object using the parser's
+L<TAP::Parser::ResultFactory>, and return it.  Passes through any arguments
+given.
+
+The C<result_factory_class> can be customized, as described in L</new>.
+
+=cut
+
+# This should make overriding behaviour of the Parser in subclasses easier:
+sub make_source      { shift->source_class->new(@_); }
+sub make_perl_source { shift->perl_source_class->new(@_); }
+sub make_grammar     { shift->grammar_class->new(@_); }
+sub make_iterator    { shift->iterator_factory_class->make_iterator(@_); }
+sub make_result      { shift->result_factory_class->make_result(@_); }
+
+sub _iterator_for_source {
+    my ( $self, $source ) = @_;
+
+    # If the source has a get_stream method then use it. This makes it
+    # possible to pass a pre-existing source object to the parser's
+    # constructor.
+    if ( UNIVERSAL::can( $source, 'can' ) && $source->can('get_stream') ) {
+        return $source->get_stream($self);
+    }
+    else {
+        return $self->iterator_factory_class->make_iterator($source);
+    }
+}
+
 {
 
     # of the following, anything beginning with an underscore is strictly
@@ -305,6 +400,14 @@ sub run {
       EOF
     );
 
+    my @class_overrides = qw(
+      source_class
+      perl_source_class
+      grammar_class
+      iterator_factory_class
+      result_factory_class
+    );
+
     sub _initialize {
         my ( $self, $arg_for ) = @_;
 
@@ -316,14 +419,22 @@ sub run {
 
         $self->SUPER::_initialize( \%args, \@legal_callback );
 
-        my $stream    = delete $args{stream};
-        my $tap       = delete $args{tap};
-        my $source    = delete $args{source};
-        my $exec      = delete $args{exec};
-        my $merge     = delete $args{merge};
-        my $spool     = delete $args{spool};
-        my $switches  = delete $args{switches};
-        my @test_args = @{ delete $args{test_args} || [] };
+        # get any class overrides out first:
+        for my $key (@class_overrides) {
+            my $default_method = "_default_$key";
+            my $val = delete $args{$key} || $self->$default_method();
+            $self->$key($val);
+        }
+
+        my $stream      = delete $args{stream};
+        my $tap         = delete $args{tap};
+        my $source      = delete $args{source};
+        my $exec        = delete $args{exec};
+        my $merge       = delete $args{merge};
+        my $spool       = delete $args{spool};
+        my $switches    = delete $args{switches};
+        my $ignore_exit = delete $args{ignore_exit};
+        my @test_args   = @{ delete $args{test_args} || [] };
 
         if ( 1 < grep {defined} $stream, $tap, $source, $exec ) {
             $self->_croak(
@@ -336,30 +447,27 @@ sub run {
         }
 
         if ($tap) {
-            $stream = TAP::Parser::Iterator->new( [ split "\n" => $tap ] );
+            $stream = $self->_iterator_for_source( [ split "\n" => $tap ] );
         }
         elsif ($exec) {
-            my $source = TAP::Parser::Source->new;
+            my $source = $self->make_source;
             $source->source( [ @$exec, @test_args ] );
             $source->merge($merge);    # XXX should just be arguments?
-            $stream = $source->get_stream;
+            $stream = $source->get_stream($self);
         }
         elsif ($source) {
-            if ( my $ref = ref $source ) {
-                $stream = TAP::Parser::Iterator->new($source);
+            if ( ref $source ) {
+                $stream = $self->_iterator_for_source($source);
             }
             elsif ( -e $source ) {
-
-                my $perl = TAP::Parser::Source::Perl->new;
+                my $perl = $self->make_perl_source;
 
                 $perl->switches($switches)
                   if $switches;
 
                 $perl->merge($merge);    # XXX args to new()?
-
                 $perl->source( [ $source, @test_args ] );
-
-                $stream = $perl->get_stream;
+                $stream = $perl->get_stream($self);
             }
             else {
                 $self->_croak("Cannot determine source for $source");
@@ -375,12 +483,8 @@ sub run {
         }
 
         $self->_stream($stream);
-        my $grammar = TAP::Parser::Grammar->new($stream);
-        $grammar->set_version( $self->version );
-        $self->_grammar($grammar);
         $self->_spool($spool);
-
-        $self->start_time( $self->get_time );
+        $self->ignore_exit($ignore_exit);
 
         return $self;
     }
@@ -919,8 +1023,7 @@ sub has_problems {
     return
          $self->failed
       || $self->parse_errors
-      || $self->wait
-      || $self->exit;
+      || ( !$self->ignore_exit && ( $self->wait || $self->exit ) );
 }
 
 =head3 C<version>
@@ -946,6 +1049,20 @@ Once the parser is done, this will return the wait status.  If the parser ran
 an executable, it returns the wait status of the executable.  Otherwise, this
 mererely returns the C<exit> status.
 
+=head2 C<ignore_exit>
+
+  $parser->ignore_exit(1);
+
+Tell the parser to ignore the exit status from the test when determining
+whether the test passed. Normally tests with non-zero exit status are
+considered to have failed even if all individual tests passed. In cases
+where it is not possible to control the exit value of the test script
+use this option to ignore it.
+
+=cut
+
+sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) }
+
 =head3 C<parse_errors>
 
  my @errors = $parser->parse_errors; # the parser errors
@@ -1230,14 +1347,28 @@ determine the readiness of this parser.
 
 sub get_select_handles { shift->_stream->get_select_handles }
 
+sub _grammar {
+    my $self = shift;
+    return $self->{_grammar} = shift if @_;
+
+    return $self->{_grammar} ||= $self->make_grammar(
+        {   stream  => $self->_stream,
+            parser  => $self,
+            version => $self->version
+        }
+    );
+}
+
 sub _iter {
     my $self        = shift;
     my $stream      = $self->_stream;
-    my $spool       = $self->_spool;
     my $grammar     = $self->_grammar;
+    my $spool       = $self->_spool;
     my $state       = 'INIT';
     my $state_table = $self->_make_state_table;
 
+    $self->start_time( $self->get_time );
+
     # Make next_state closure
     my $next_state = sub {
         my $token = shift;
@@ -1330,6 +1461,18 @@ sub _finish {
 
     $self->end_time( $self->get_time );
 
+    # Avoid leaks
+    $self->_stream(undef);
+    $self->_grammar(undef);
+
+    # If we just delete the iter we won't get a fault if it's recreated.
+    # Instead we set it to a sub that returns an infinite
+    # stream of undef. This segfaults on 5.5.4, presumably because
+    # we're still executing the closure that gets replaced and it hasn't
+    # been protected with a refcount.
+    $self->{_iter} = sub {return}
+      if $] >= 5.006;
+
     # sanity checks
     if ( !$self->plan ) {
         $self->_add_error('No plan found in TAP output');
@@ -1542,6 +1685,110 @@ never run. They're reported as parse failures (tests out of sequence).
 
 =back
 
+=head1 SUBCLASSING
+
+If you find you need to provide custom functionality (as you would have using
+L<Test::Harness::Straps>), you're in luck: C<TAP::Parser> and friends are
+designed to be easily subclassed.
+
+Before you start, it's important to know a few things:
+
+=over 2
+
+=item 1
+
+All C<TAP::*> objects inherit from L<TAP::Object>.
+
+=item 2
+
+Most C<TAP::*> classes have a I<SUBCLASSING> section to guide you.
+
+=item 3
+
+Note that C<TAP::Parser> is designed to be the central 'maker' - ie: it is
+responsible for creating new objects in the C<TAP::Parser::*> namespace.
+
+This makes it possible for you to have a single point of configuring what
+subclasses should be used, which in turn means that in many cases you'll find
+you only need to sub-class one of the parser's components.
+
+=item 4
+
+By subclassing, you may end up overriding undocumented methods.  That's not
+a bad thing per se, but be forewarned that undocumented methods may change
+without warning from one release to the next - we cannot guarantee backwards
+compatability.  If any I<documented> method needs changing, it will be
+deprecated first, and changed in a later release.
+
+=back
+
+=head2 Parser Components
+
+=head3 Sources
+
+A TAP parser consumes input from a I<source>.  There are currently two types
+of sources: L<TAP::Parser::Source> for general non-perl commands, and
+L<TAP::Parser::Source::Perl>.  You can subclass both of them.  You'll need to
+customize your parser by setting the C<source_class> & C<perl_source_class>
+parameters.  See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_source> or L</make_perl_source>.
+
+=head3 Iterators
+
+A TAP parser uses I<iterators> to loop through the I<stream> provided by the
+parser's I<source>.  There are quite a few types of Iterators available.
+Choosing which class to use is the responsibility of the I<iterator factory>.
+
+To create your own iterators you'll have to subclass
+L<TAP::Parser::IteratorFactory> and L<TAP::Parser::Iterator>.  Then you'll
+need to customize the class used by your parser by setting the
+C<iterator_factory_class> parameter.  See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_iterator>.
+
+=head3 Results
+
+A TAP parser creates L<TAP::Parser::Result>s as it iterates through the
+input I<stream>.  There are quite a few result types available; choosing
+which class to use is the responsibility of the I<result factory>.
+
+To create your own result types you have two options:
+
+=over 2
+
+=item option 1
+
+Subclass L<TAP::Parser::Result> and register your new result type/class with
+the default L<TAP::Parser::ResultFactory>.
+
+=item option 2
+
+Subclass L<TAP::Parser::ResultFactory> itself and implement your own
+L<TAP::Parser::Result> creation logic.  Then you'll need to customize the
+class used by your parser by setting the C<result_factory_class> parameter.
+See L</new> for more details.
+
+=back
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_result>.
+
+=head3 Grammar
+
+L<TAP::Parser::Grammar> is the heart of the parser - it tokenizes the TAP
+input I<stream> and produces results.  If you need to customize its behaviour
+you should probably familiarize yourself with the source first.  Enough
+lecturing.
+
+Subclass L<TAP::Parser::Grammar> and customize your parser by setting the
+C<grammar_class> parameter.  See L</new> for more details.
+
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_grammar>
+
 =head1 ACKNOWLEDGEMENTS
 
 All of the following have helped. Bug reports, patches, (im)moral
@@ -1583,6 +1830,10 @@ support, or just words of encouragement have all been forthcoming.
 
 =item * Matt Kraai
 
+=item * David Wheeler
+
+=item * Alex Vandiver
+
 =back
 
 =head1 AUTHORS
@@ -1597,11 +1848,13 @@ Michael Peters <mpeters at plusthree dot com>
 
 Leif Eriksen <leif dot eriksen at bigpond dot com>
 
+Steve Purkis <spurkis@cpan.org>
+
 =head1 BUGS
 
 Please report any bugs or feature requests to
-C<bug-tapx-parser@rt.cpan.org>, or through the web interface at
-L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=TAP-Parser>.
+C<bug-test-harness@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.
 We will be notified, and then you'll automatically be notified of
 progress on your bug as we make changes.
 
index c3fc726..5ed7fdb 100644 (file)
@@ -2,7 +2,11 @@ package TAP::Parser::Aggregator;
 
 use strict;
 use Benchmark;
-use vars qw($VERSION);
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
 
 =head1 NAME
 
@@ -10,11 +14,11 @@ TAP::Parser::Aggregator - Aggregate TAP::Parser results
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 SYNOPSIS
 
@@ -51,6 +55,8 @@ Returns a new C<TAP::Parser::Aggregator> object.
 
 =cut
 
+# new() implementation supplied by TAP::Object
+
 my %SUMMARY_METHOD_FOR;
 
 BEGIN {    # install summary methods
@@ -79,13 +85,6 @@ BEGIN {    # install summary methods
     }
 }    # end install summary methods
 
-sub new {
-    my ($class) = @_;
-    my $self = bless {}, $class;
-    $self->_initialize;
-    return $self;
-}
-
 sub _initialize {
     my ($self) = @_;
     $self->{parser_for}  = {};
@@ -124,6 +123,13 @@ sub add {
     $self->{parser_for}{$description} = $parser;
 
     while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
+
+        # Slightly nasty. Instead we should maybe have 'cooked' accessors
+        # for results that may be masked by the parser.
+        next
+          if ( $method eq 'exit' || $method eq 'wait' )
+          && $parser->ignore_exit;
+
         if ( my $count = $parser->$method() ) {
             $self->{$summary} += $count;
             push @{ $self->{"descriptions_for_$summary"} } => $description;
@@ -395,12 +401,6 @@ sub todo_failed {
     goto &todo_passed;
 }
 
-sub _croak {
-    my $proto = shift;
-    require Carp;
-    Carp::croak(@_);
-}
-
 =head1 See Also
 
 L<TAP::Parser>
index 4478ddc..d56d0cb 100644 (file)
@@ -1,22 +1,36 @@
 package TAP::Parser::Grammar;
 
 use strict;
-use vars qw($VERSION);
+use vars qw($VERSION @ISA);
 
-use TAP::Parser::Result          ();
+use TAP::Object                  ();
+use TAP::Parser::ResultFactory   ();
 use TAP::Parser::YAMLish::Reader ();
 
+@ISA = qw(TAP::Object);
+
 =head1 NAME
 
 TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::Grammar;
+  my $grammar = $self->make_grammar({
+    stream  => $tap_parser_stream,
+    parser  => $tap_parser,
+    version => 12,
+  });
+
+  my $result = $grammar->tokenize;
 
 =head1 DESCRIPTION
 
@@ -28,25 +42,30 @@ here to ensure that we will be able to have pluggable grammars when TAP is
 expanded at some future date (plus, this stuff was really cluttering the
 parser).
 
-=cut
-
-##############################################################################
+=head1 METHODS
 
 =head2 Class Methods
 
-
 =head3 C<new>
 
-  my $grammar = TAP::Grammar->new($stream);
+  my $grammar = TAP::Parser::Grammar->new({
+      stream  => $stream,
+      parser  => $parser,
+      version => $version,
+  });
 
-Returns TAP grammar object that will parse the specified stream.
+Returns L<TAP::Parser> grammar object that will parse the specified stream.
+Both C<stream> and C<parser> are required arguments.  If C<version> is not set
+it defaults to C<12> (see L</set_version> for more details).
 
 =cut
 
-sub new {
-    my ( $class, $stream ) = @_;
-    my $self = bless { stream => $stream }, $class;
-    $self->set_version(12);
+# new() implementation supplied by TAP::Object
+sub _initialize {
+    my ( $self, $args ) = @_;
+    $self->{stream} = $args->{stream};    # TODO: accessor
+    $self->{parser} = $args->{parser};    # TODO: accessor
+    $self->set_version( $args->{version} || 12 );
     return $self;
 }
 
@@ -83,13 +102,10 @@ my %language_for;
                     );
                 }
                 elsif ( 0 == $tests_planned ) {
-                    $skip        = 'SKIP';
-                    $explanation = $tail;
+                    $skip = 'SKIP';
 
-                    # Trim valid SKIP directive without being strict
-                    # about its presence.
-                    $explanation =~ s/^#\s*//;
-                    $explanation =~ s/^skip\S*\s+//i;
+                    # If we can't match # SKIP the directive should be undef.
+                    ($explanation) = $tail =~ /^#\s*SKIP\s+(.*)/i;
                 }
                 elsif ( $tail !~ /^\s*$/ ) {
                     return $self->_make_unknown_token($line);
@@ -227,7 +243,8 @@ sub set_version {
     my $version = shift;
 
     if ( my $language = $language_for{$version} ) {
-        $self->{tokens} = $language->{tokens};
+        $self->{version} = $version;
+        $self->{tokens}  = $language->{tokens};
 
         if ( my $setup = $language->{setup} ) {
             $self->$setup();
@@ -268,7 +285,10 @@ sub tokenize {
     my $self = shift;
 
     my $line = $self->{stream}->next;
-    return unless defined $line;
+    unless ( defined $line ) {
+        delete $self->{parser};    # break circular ref
+        return;
+    }
 
     my $token;
 
@@ -282,7 +302,7 @@ sub tokenize {
 
     $token = $self->_make_unknown_token($line) unless $token;
 
-    return TAP::Parser::Result->new($token);
+    return $self->{parser}->make_result($token);
 }
 
 ##############################################################################
@@ -361,10 +381,14 @@ sub _make_version_token {
 sub _make_plan_token {
     my ( $self, $line, $tests_planned, $directive, $explanation, $todo ) = @_;
 
-    if ( $directive eq 'SKIP' && 0 != $tests_planned ) {
+    if (   $directive eq 'SKIP'
+        && 0 != $tests_planned
+        && $self->{version} < 13 )
+    {
         warn
           "Specified SKIP directive in plan but more than 0 tests ($line)\n";
     }
+
     return {
         type          => 'plan',
         raw           => $line,
@@ -467,6 +491,8 @@ sub _trim {
     return $data;
 }
 
+1;
+
 =head1 TAP GRAMMAR
 
 B<NOTE:>  This grammar is slightly out of date.  There's still some discussion
@@ -538,7 +564,18 @@ A formal grammar would look similar to the following:
  positiveInteger    ::= ( digit - '0' ) {digit}
  nonNegativeInteger ::= digit {digit}
 
+=head1 SUBCLASSING
 
-=cut
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
 
-1;
+If you I<really> want to subclass L<TAP::Parser>'s grammar the best thing to
+do is read through the code.  There's no easy way of summarizing it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Result>,
+
+=cut
index d01b843..0d471d9 100644 (file)
@@ -1,48 +1,49 @@
 package TAP::Parser::Iterator;
 
 use strict;
-use vars qw($VERSION);
+use vars qw($VERSION @ISA);
 
-use TAP::Parser::Iterator::Array   ();
-use TAP::Parser::Iterator::Stream  ();
-use TAP::Parser::Iterator::Process ();
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
 
 =head1 NAME
 
-TAP::Parser::Iterator - Internal TAP::Parser Iterator
+TAP::Parser::Iterator - Internal base class for TAP::Parser Iterators
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 SYNOPSIS
 
-  use TAP::Parser::Iterator;
-  my $it = TAP::Parser::Iterator->new(\*TEST);
-  my $it = TAP::Parser::Iterator->new(\@array);
-
-  my $line = $it->next;
+  # see TAP::Parser::IteratorFactory for general usage
 
-Originally ripped off from L<Test::Harness>.
+  # to subclass:
+  use vars qw(@ISA);
+  use TAP::Parser::Iterator ();
+  @ISA = qw(TAP::Parser::Iterator);
+  sub _initialize {
+    # see TAP::Object...
+  }
 
 =head1 DESCRIPTION
 
-B<FOR INTERNAL USE ONLY!>
+This is a simple iterator base class that defines L<TAP::Parser>'s iterator
+API.  See C<TAP::Parser::IteratorFactory> for the preferred way of creating
+iterators.
 
-This is a simple iterator wrapper for arrays and filehandles.
+=head1 METHODS
 
 =head2 Class Methods
 
 =head3 C<new>
 
- my $iter = TAP::Parser::Iterator->new( $array_reference );
- my $iter = TAP::Parser::Iterator->new( $filehandle );
-
-Create an iterator.
+Create an iterator.  Provided by L<TAP::Object>.
 
 =head2 Instance Methods
 
@@ -54,30 +55,14 @@ Iterate through it, of course.
 
 =head3 C<next_raw>
 
+B<Note:> this method is abstract and should be overridden.
+
  while ( my $item = $iter->next_raw ) { ... }
 
 Iterate raw input without applying any fixes for quirky input syntax.
 
 =cut
 
-sub new {
-    my ( $proto, $thing ) = @_;
-
-    my $ref = ref $thing;
-    if ( $ref eq 'GLOB' || $ref eq 'IO::Handle' ) {
-        return TAP::Parser::Iterator::Stream->new($thing);
-    }
-    elsif ( $ref eq 'ARRAY' ) {
-        return TAP::Parser::Iterator::Array->new($thing);
-    }
-    elsif ( $ref eq 'HASH' ) {
-        return TAP::Parser::Iterator::Process->new($thing);
-    }
-    else {
-        die "Can't iterate with a $ref";
-    }
-}
-
 sub next {
     my $self = shift;
     my $line = $self->next_raw;
@@ -93,11 +78,19 @@ sub next {
     return $line;
 }
 
+sub next_raw {
+    require Carp;
+    my $msg = Carp::longmess('abstract method called directly!');
+    $_[0]->_croak($msg);
+}
+
 =head3 C<handle_unicode>
 
 If necessary switch the input stream to handle unicode. This only has
 any effect for I/O handle based streams.
 
+The default implementation does nothing.
+
 =cut
 
 sub handle_unicode { }
@@ -106,10 +99,67 @@ sub handle_unicode { }
 
 Return a list of filehandles that may be used upstream in a select()
 call to signal that this Iterator is ready. Iterators that are not
-handle based should return an empty list.
+handle-based should return an empty list.
+
+The default implementation does nothing.
+
+=cut
+
+sub get_select_handles {
+    return;
+}
+
+=head3 C<wait>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->wait;
+
+Return the C<wait> status for this iterator.
+
+=head3 C<exit>
+
+B<Note:> this method is abstract and should be overridden.
+
+ my $wait_status = $iter->exit;
+
+Return the C<exit> status for this iterator.
 
 =cut
 
-sub get_select_handles {return}
+sub wait {
+    require Carp;
+    my $msg = Carp::longmess('abstract method called directly!');
+    $_[0]->_croak($msg);
+}
+
+sub exit {
+    require Carp;
+    my $msg = Carp::longmess('abstract method called directly!');
+    $_[0]->_croak($msg);
+}
 
 1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+You must override the abstract methods as noted above.
+
+=head2 Example
+
+L<TAP::Parser::Iterator::Array> is probably the easiest example to follow.
+There's not much point repeating it here.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
+L<TAP::Parser::Iterator::Array>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::Iterator::Process>,
+
+=cut
+
index e6412c6..3eef09a 100644 (file)
@@ -1,42 +1,47 @@
 package TAP::Parser::Iterator::Array;
 
 use strict;
-use TAP::Parser::Iterator ();
 use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+
 @ISA = 'TAP::Parser::Iterator';
 
 =head1 NAME
 
-TAP::Parser::Iterator::Array - Internal TAP::Parser Iterator
+TAP::Parser::Iterator::Array - Internal TAP::Parser array Iterator
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 SYNOPSIS
 
-  use TAP::Parser::Iterator::Array;
-  my $it = TAP::Parser::Iterator->new(\@array);
+  # see TAP::Parser::IteratorFactory for preferred usage
 
+  # to use directly:
+  use TAP::Parser::Iterator::Array;
+  my @data = ('foo', 'bar', baz');
+  my $it   = TAP::Parser::Iterator::Array->new(\@data);
   my $line = $it->next;
 
-Originally ripped off from L<Test::Harness>.
-
 =head1 DESCRIPTION
 
-B<FOR INTERNAL USE ONLY!>
+This is a simple iterator wrapper for arrays of scalar content, used by
+L<TAP::Parser>.  Unless you're subclassing, you probably won't need to use
+this module directly.
 
-This is a simple iterator wrapper for arrays.
+=head1 METHODS
 
 =head2 Class Methods
 
 =head3 C<new>
 
-Create an iterator.
+Create an iterator.  Takes one argument: an C<$array_ref>
 
 =head2 Instance Methods
 
@@ -60,14 +65,15 @@ be zero.
 
 =cut
 
-sub new {
-    my ( $class, $thing ) = @_;
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+    my ( $self, $thing ) = @_;
     chomp @$thing;
-    bless {
-        idx   => 0,
-        array => $thing,
-        exit  => undef,
-    }, $class;
+    $self->{idx}   = 0;
+    $self->{array} = $thing;
+    $self->{exit}  = undef;
+    return $self;
 }
 
 sub wait { shift->exit }
@@ -84,3 +90,17 @@ sub next_raw {
 }
 
 1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
index 345e214..bcc3420 100644 (file)
@@ -1,16 +1,14 @@
 package TAP::Parser::Iterator::Process;
 
 use strict;
-
-use TAP::Parser::Iterator ();
-
 use vars qw($VERSION @ISA);
 
-@ISA = 'TAP::Parser::Iterator';
-
+use TAP::Parser::Iterator ();
 use Config;
 use IO::Handle;
 
+@ISA = 'TAP::Parser::Iterator';
+
 my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
 
 =head1 NAME
@@ -19,38 +17,54 @@ TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 SYNOPSIS
 
-  use TAP::Parser::Iterator;
-  my $it = TAP::Parser::Iterator::Process->new(@args);
-
+  # see TAP::Parser::IteratorFactory for preferred usage
+
+  # to use directly:
+  use TAP::Parser::Iterator::Process;
+  my %args = (
+   command  => ['python', 'setup.py', 'test'],
+   merge    => 1,
+   setup    => sub { ... },
+   teardown => sub { ... },
+  );
+  my $it   = TAP::Parser::Iterator::Process->new(\%args);
   my $line = $it->next;
 
-Originally ripped off from L<Test::Harness>.
-
 =head1 DESCRIPTION
 
-B<FOR INTERNAL USE ONLY!>
+This is a simple iterator wrapper for executing external processes, used by
+L<TAP::Parser>.  Unless you're subclassing, you probably won't need to use
+this module directly.
 
-This is a simple iterator wrapper for processes.
+=head1 METHODS
 
 =head2 Class Methods
 
 =head3 C<new>
 
-Create an iterator.
+Create an iterator.  Expects one argument containing a hashref of the form:
+
+   command  => \@command_to_execute
+   merge    => $attempt_merge_stderr_and_stdout?
+   setup    => $callback_to_setup_command
+   teardown => $callback_to_teardown_command
+
+Tries to uses L<IPC::Open3> & L<IO::Select> to communicate with the spawned
+process if they are available.  Falls back onto C<open()>.
 
 =head2 Instance Methods
 
 =head3 C<next>
 
-Iterate through it, of course.
+Iterate through the process output, of course.
 
 =head3 C<next_raw>
 
@@ -95,9 +109,10 @@ sub _use_open3 {
     }
 }
 
-sub new {
-    my $class = shift;
-    my $args  = shift;
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+    my ( $self, $args ) = @_;
 
     my @command = @{ delete $args->{command} || [] }
       or die "Must supply a command to execute";
@@ -114,7 +129,7 @@ sub new {
 
     my $out = IO::Handle->new;
 
-    if ( $class->_use_open3 ) {
+    if ( $self->_use_open3 ) {
 
         # HOTPATCH {{{
         my $xclose = \&IPC::Open3::xclose;
@@ -158,14 +173,12 @@ sub new {
           or die "Could not execute ($command): $!";
     }
 
-    my $self = bless {
-        out        => $out,
-        err        => $err,
-        sel        => $sel,
-        pid        => $pid,
-        exit       => undef,
-        chunk_size => $chunk_size,
-    }, $class;
+    $self->{out}        = $out;
+    $self->{err}        = $err;
+    $self->{sel}        = $sel;
+    $self->{pid}        = $pid;
+    $self->{exit}       = undef;
+    $self->{chunk_size} = $chunk_size;
 
     if ( my $teardown = delete $args->{teardown} ) {
         $self->{teardown} = sub {
@@ -298,6 +311,10 @@ sub _finish {
 
     my $status = $?;
 
+    # Avoid circular refs
+    $self->{_next} = sub {return}
+      if $] >= 5.006;
+
     # If we have a subprocess we need to wait for it to terminate
     if ( defined $self->{pid} ) {
         if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) {
@@ -344,3 +361,17 @@ sub get_select_handles {
 }
 
 1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
index ab3d602..3f2febf 100644 (file)
@@ -1,8 +1,10 @@
 package TAP::Parser::Iterator::Stream;
 
 use strict;
-use TAP::Parser::Iterator ();
 use vars qw($VERSION @ISA);
+
+use TAP::Parser::Iterator ();
+
 @ISA = 'TAP::Parser::Iterator';
 
 =head1 NAME
@@ -11,32 +13,45 @@ TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 SYNOPSIS
 
-  use TAP::Parser::Iterator;
-  my $it = TAP::Parser::Iterator::Stream->new(\*TEST);
+  # see TAP::Parser::IteratorFactory for preferred usage
 
+  # to use directly:
+  use TAP::Parser::Iterator::Stream;
+  open( TEST, 'test.tap' );
+  my $it   = TAP::Parser::Iterator::Stream->new(\*TEST);
   my $line = $it->next;
 
-Originally ripped off from L<Test::Harness>.
-
 =head1 DESCRIPTION
 
-B<FOR INTERNAL USE ONLY!>
+This is a simple iterator wrapper for reading from filehandles, used by
+L<TAP::Parser>.  Unless you're subclassing, you probably won't need to use
+this module directly.
 
-This is a simple iterator wrapper for filehandles.
+=head1 METHODS
 
 =head2 Class Methods
 
 =head3 C<new>
 
-Create an iterator.
+Create an iterator.  Expects one argument containing a filehandle.
+
+=cut
+
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+    my ( $self, $thing ) = @_;
+    $self->{fh} = $thing;
+    return $self;
+}
 
 =head2 Instance Methods
 
@@ -58,15 +73,6 @@ Get the exit status for this iterator. Always returns zero.
 
 =cut
 
-sub new {
-    my ( $class, $thing ) = @_;
-    bless {
-        fh => $thing,
-    }, $class;
-}
-
-##############################################################################
-
 sub wait { shift->exit }
 sub exit { shift->{fh} ? () : 0 }
 
@@ -90,3 +96,17 @@ sub _finish {
 }
 
 1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
+
+=cut
+
diff --git a/lib/TAP/Parser/IteratorFactory.pm b/lib/TAP/Parser/IteratorFactory.pm
new file mode 100644 (file)
index 0000000..b2c1cdd
--- /dev/null
@@ -0,0 +1,171 @@
+package TAP::Parser::IteratorFactory;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use TAP::Object                    ();
+use TAP::Parser::Iterator::Array   ();
+use TAP::Parser::Iterator::Stream  ();
+use TAP::Parser::Iterator::Process ();
+
+@ISA = qw(TAP::Object);
+
+=head1 NAME
+
+TAP::Parser::IteratorFactory - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.13
+
+=cut
+
+$VERSION = '3.13';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::IteratorFactory;
+  my $factory = TAP::Parser::IteratorFactory->new;
+  my $iter = $factory->make_iterator(\*TEST);
+  my $iter = $factory->make_iterator(\@array);
+  my $iter = $factory->make_iterator(\%hash);
+
+  my $line = $iter->next;
+
+=head1 DESCRIPTION
+
+This is a factory class for simple iterator wrappers for arrays, filehandles,
+and hashes.  Unless you're subclassing, you probably won't need to use this
+module directly.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class.
+I<Note:> You currently don't need to instantiate a factory in order to use it.
+
+=head3 C<make_iterator>
+
+Create an iterator.  The type of iterator created depends on the arguments to
+the constructor:
+
+  my $iter = TAP::Parser::Iterator->make_iterator( $filehandle );
+
+Creates a I<stream> iterator (see L</make_stream_iterator>).
+
+  my $iter = TAP::Parser::Iterator->make_iterator( $array_reference );
+
+Creates an I<array> iterator (see L</make_array_iterator>).
+
+  my $iter = TAP::Parser::Iterator->make_iterator( $hash_reference );
+
+Creates a I<process> iterator (see L</make_process_iterator>).
+
+=cut
+
+sub make_iterator {
+    my ( $proto, $thing ) = @_;
+
+    my $ref = ref $thing;
+    if ( $ref eq 'GLOB' || $ref eq 'IO::Handle' ) {
+        return $proto->make_stream_iterator($thing);
+    }
+    elsif ( $ref eq 'ARRAY' ) {
+        return $proto->make_array_iterator($thing);
+    }
+    elsif ( $ref eq 'HASH' ) {
+        return $proto->make_process_iterator($thing);
+    }
+    else {
+        die "Can't iterate with a $ref";
+    }
+}
+
+=head3 C<make_stream_iterator>
+
+Make a new stream iterator and return it.  Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Stream>.
+
+=head3 C<make_array_iterator>
+
+Make a new array iterator and return it.  Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Array>.
+
+=head3 C<make_process_iterator>
+
+Make a new process iterator and return it.  Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Process>.
+
+=cut
+
+sub make_stream_iterator {
+    my $proto = shift;
+    TAP::Parser::Iterator::Stream->new(@_);
+}
+
+sub make_array_iterator {
+    my $proto = shift;
+    TAP::Parser::Iterator::Array->new(@_);
+}
+
+sub make_process_iterator {
+    my $proto = shift;
+    TAP::Parser::Iterator::Process->new(@_);
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+There are a few things to bear in mind when creating your own
+C<ResultFactory>:
+
+=over 4
+
+=item 1
+
+The factory itself is never instantiated (this I<may> change in the future).
+This means that C<_initialize> is never called.
+
+=back
+
+=head2 Example
+
+  package MyIteratorFactory;
+
+  use strict;
+  use vars '@ISA';
+
+  use MyStreamIterator;
+  use TAP::Parser::IteratorFactory;
+
+  @ISA = qw( TAP::Parser::IteratorFactory );
+
+  # override stream iterator
+  sub make_stream_iterator {
+    my $proto = shift;
+    MyStreamIterator->new(@_);
+  }
+
+  1;
+
+=head1 ATTRIBUTION
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Iterator::Array>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::Iterator::Process>,
+
+=cut
+
index b05c0b3..f572756 100644 (file)
@@ -1,24 +1,28 @@
 package TAP::Parser::Multiplexer;
 
 use strict;
+use vars qw($VERSION @ISA);
+
 use IO::Select;
-use vars qw($VERSION);
+use TAP::Object ();
 
 use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/;
 use constant IS_VMS => $^O eq 'VMS';
 use constant SELECT_OK => !( IS_VMS || IS_WIN32 );
 
+@ISA = 'TAP::Object';
+
 =head1 NAME
 
 TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 SYNOPSIS
 
@@ -51,13 +55,14 @@ Returns a new C<TAP::Parser::Multiplexer> object.
 
 =cut
 
-sub new {
-    my ($class) = @_;
-    return bless {
-        select => IO::Select->new,
-        avid   => [],                # Parsers that can't select
-        count  => 0,
-    }, $class;
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+    my $self = shift;
+    $self->{select} = IO::Select->new;
+    $self->{avid}   = [];                # Parsers that can't select
+    $self->{count}  = 0;
+    return $self;
 }
 
 ##############################################################################
@@ -128,8 +133,6 @@ sub _iter {
 
         unless (@ready) {
             return unless $sel->count;
-
-            # TODO: Win32 doesn't do select properly on handles...
             @ready = $sel->can_read;
         }
 
index 686e8f1..eb27a19 100644 (file)
@@ -1,35 +1,18 @@
 package TAP::Parser::Result;
 
 use strict;
-use vars qw($VERSION);
+use vars qw($VERSION @ISA);
 
-use TAP::Parser::Result::Bailout ();
-use TAP::Parser::Result::Comment ();
-use TAP::Parser::Result::Plan    ();
-use TAP::Parser::Result::Pragma  ();
-use TAP::Parser::Result::Test    ();
-use TAP::Parser::Result::Unknown ();
-use TAP::Parser::Result::Version ();
-use TAP::Parser::Result::YAML    ();
+use TAP::Object ();
 
-# note that this is bad.  Makes it very difficult to subclass, but then, it
-# would be a lot of work to subclass this system.
-my %class_for;
+@ISA = 'TAP::Object';
 
 BEGIN {
-    %class_for = (
-        plan    => 'TAP::Parser::Result::Plan',
-        pragma  => 'TAP::Parser::Result::Pragma',
-        test    => 'TAP::Parser::Result::Test',
-        comment => 'TAP::Parser::Result::Comment',
-        bailout => 'TAP::Parser::Result::Bailout',
-        version => 'TAP::Parser::Result::Version',
-        unknown => 'TAP::Parser::Result::Unknown',
-        yaml    => 'TAP::Parser::Result::YAML',
-    );
 
+    # make is_* methods
+    my @attrs = qw( plan pragma test comment bailout version unknown yaml );
     no strict 'refs';
-    for my $token ( keys %class_for ) {
+    for my $token (@attrs) {
         my $method = "is_$token";
         *$method = sub { return $token eq shift->type };
     }
@@ -39,47 +22,60 @@ BEGIN {
 
 =head1 NAME
 
-TAP::Parser::Result - TAP::Parser output
+TAP::Parser::Result - Base class for TAP::Parser output objects
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
-=head2 DESCRIPTION
+=head1 SYNOPSIS
 
-This is merely a factory class which returns an object representing the
-current bit of test data from TAP (usually a line).  It's for internal use
-only and should not be relied upon.
+  # abstract class - not meany to be used directly
+  # see TAP::Parser::ResultFactory for preferred usage
 
-=cut
+  # directly:
+  use TAP::Parser::Result;
+  my $token  = {...};
+  my $result = TAP::Parser::Result->new( $token );
 
-##############################################################################
+=head2 DESCRIPTION
+
+This is a simple base class used by L<TAP::Parser> to store objects that
+represent the current bit of test output data from TAP (usually a single
+line).  Unless you're subclassing, you probably won't need to use this module
+directly.
 
 =head2 METHODS
 
 =head3 C<new>
 
+  # see TAP::Parser::ResultFactory for preferred usage
+
+  # to use directly:
   my $result = TAP::Parser::Result->new($token);
 
 Returns an instance the appropriate class for the test token passed in.
 
 =cut
 
-sub new {
-    my ( $class, $token ) = @_;
-    my $type = $token->{type};
-    return bless $token => $class_for{$type}
-      if exists $class_for{$type};
-    require Carp;
+# new() implementation provided by TAP::Object
 
-    # this should never happen!
-    Carp::croak("Could not determine class for\n$token->{type}");
+sub _initialize {
+    my ( $self, $token ) = @_;
+    if ($token) {
+
+        # make a shallow copy of the token:
+        $self->{$_} = $token->{$_} for ( keys %$token );
+    }
+    return $self;
 }
 
+##############################################################################
+
 =head2 Boolean methods
 
 The following methods all return a boolean value and are to be overridden in
@@ -260,3 +256,43 @@ sub set_directive {
 }
 
 1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+Remember: if you want your subclass to be automatically used by the parser,
+you'll have to register it with L<TAP::Parser::ResultFactory/register_type>.
+
+If you're creating a completely new result I<type>, you'll probably need to
+subclass L<TAP::Parser::Grammar> too, or else it'll never get used.
+
+=head2 Example
+
+  package MyResult;
+
+  use strict;
+  use vars '@ISA';
+
+  @ISA = 'TAP::Parser::Result';
+
+  # register with the factory:
+  TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+  sub as_string { 'My results all look the same' }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::ResultFactory>,
+L<TAP::Parser::Result::Bailout>,
+L<TAP::Parser::Result::Comment>,
+L<TAP::Parser::Result::Plan>,
+L<TAP::Parser::Result::Pragma>,
+L<TAP::Parser::Result::Test>,
+L<TAP::Parser::Result::Unknown>,
+L<TAP::Parser::Result::Version>,
+L<TAP::PARSER::RESULT::YAML>,
+
+=cut
index 28bc073..b20d031 100644 (file)
@@ -12,11 +12,11 @@ TAP::Parser::Result::Bailout - Bailout result token.
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
index 0f1f5f7..aaa78da 100644 (file)
@@ -12,11 +12,11 @@ TAP::Parser::Result::Comment - Comment result token.
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
index 9f636fd..c851f22 100644 (file)
@@ -12,11 +12,11 @@ TAP::Parser::Result::Plan - Plan result token.
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
index 9f8bcad..b89c713 100644 (file)
@@ -12,11 +12,11 @@ TAP::Parser::Result::Pragma - TAP pragma token.
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
index 784e6a1..b36a7ce 100644 (file)
@@ -14,11 +14,11 @@ TAP::Parser::Result::Test - Test result token.
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
index a6b7313..47c888e 100644 (file)
@@ -14,11 +14,11 @@ TAP::Parser::Result::Unknown - Unknown result token.
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
index 9d9718a..62bac2e 100644 (file)
@@ -12,11 +12,11 @@ TAP::Parser::Result::Version - TAP syntax version token.
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
index 74b3a47..f1b99ef 100644 (file)
@@ -12,11 +12,11 @@ TAP::Parser::Result::YAML - YAML result token.
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 DESCRIPTION
 
diff --git a/lib/TAP/Parser/ResultFactory.pm b/lib/TAP/Parser/ResultFactory.pm
new file mode 100644 (file)
index 0000000..bf4797f
--- /dev/null
@@ -0,0 +1,189 @@
+package TAP::Parser::ResultFactory;
+
+use strict;
+use vars qw($VERSION @ISA %CLASS_FOR);
+
+use TAP::Object                  ();
+use TAP::Parser::Result::Bailout ();
+use TAP::Parser::Result::Comment ();
+use TAP::Parser::Result::Plan    ();
+use TAP::Parser::Result::Pragma  ();
+use TAP::Parser::Result::Test    ();
+use TAP::Parser::Result::Unknown ();
+use TAP::Parser::Result::Version ();
+use TAP::Parser::Result::YAML    ();
+
+@ISA = 'TAP::Object';
+
+##############################################################################
+
+=head1 NAME
+
+TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::ResultFactory;
+  my $token   = {...};
+  my $factory = TAP::Parser::ResultFactory->new;
+  my $result  = $factory->make_result( $token );
+
+=head1 VERSION
+
+Version 3.13
+
+=cut
+
+$VERSION = '3.13';
+
+=head2 DESCRIPTION
+
+This is a simple factory class which returns a L<TAP::Parser::Result> subclass
+representing the current bit of test data from TAP (usually a single line).
+It is used primarily by L<TAP::Parser::Grammar>.  Unless you're subclassing,
+you probably won't need to use this module directly.
+
+=head2 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Creates a new factory class.
+I<Note:> You currently don't need to instantiate a factory in order to use it.
+
+=head3 C<make_result>
+
+Returns an instance the appropriate class for the test token passed in.
+
+  my $result = TAP::Parser::ResultFactory->make_result($token);
+
+Can also be called as an instance method.
+
+=cut
+
+sub make_result {
+    my ( $proto, $token ) = @_;
+    my $type = $token->{type};
+    return $proto->class_for($type)->new($token);
+}
+
+=head3 C<class_for>
+
+Takes one argument: C<$type>.  Returns the class for this $type, or C<croak>s
+with an error.
+
+=head3 C<register_type>
+
+Takes two arguments: C<$type>, C<$class>
+
+This lets you override an existing type with your own custom type, or register
+a completely new type, eg:
+
+  # create a custom result type:
+  package MyResult;
+  use strict;
+  use vars qw(@ISA);
+  @ISA = 'TAP::Parser::Result';
+
+  # register with the factory:
+  TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+
+  # use it:
+  my $r = TAP::Parser::ResultFactory->( { type => 'my_type' } );
+
+Your custom type should then be picked up automatically by the L<TAP::Parser>.
+
+=cut
+
+BEGIN {
+    %CLASS_FOR = (
+        plan    => 'TAP::Parser::Result::Plan',
+        pragma  => 'TAP::Parser::Result::Pragma',
+        test    => 'TAP::Parser::Result::Test',
+        comment => 'TAP::Parser::Result::Comment',
+        bailout => 'TAP::Parser::Result::Bailout',
+        version => 'TAP::Parser::Result::Version',
+        unknown => 'TAP::Parser::Result::Unknown',
+        yaml    => 'TAP::Parser::Result::YAML',
+    );
+}
+
+sub class_for {
+    my ( $class, $type ) = @_;
+
+    # return target class:
+    return $CLASS_FOR{$type} if exists $CLASS_FOR{$type};
+
+    # or complain:
+    require Carp;
+    Carp::croak("Could not determine class for result type '$type'");
+}
+
+sub register_type {
+    my ( $class, $type, $rclass ) = @_;
+
+    # register it blindly, assume they know what they're doing
+    $CLASS_FOR{$type} = $rclass;
+    return $class;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+There are a few things to bear in mind when creating your own
+C<ResultFactory>:
+
+=over 4
+
+=item 1
+
+The factory itself is never instantiated (this I<may> change in the future).
+This means that C<_initialize> is never called.
+
+=item 2
+
+C<TAP::Parser::Result-E<gt>new> is never called, $tokens are reblessed.
+This I<will> change in a future version!
+
+=item 3
+
+L<TAP::Parser::Result> subclasses will register themselves with
+L<TAP::Parser::ResultFactory> directly:
+
+  package MyFooResult;
+  TAP::Parser::ResultFactory->register_type( foo => __PACKAGE__ );
+
+Of course, it's up to you to decide whether or not to ignore them.
+
+=back
+
+=head2 Example
+
+  package MyResultFactory;
+
+  use strict;
+  use vars '@ISA';
+
+  use MyResult;
+  use TAP::Parser::ResultFactory;
+
+  @ISA = qw( TAP::Parser::ResultFactory );
+
+  # force all results to be 'MyResult'
+  sub class_for {
+    return 'MyResult';
+  }
+
+  1;
+
+=head1 SEE ALSO
+
+L<TAP::Parser>,
+L<TAP::Parser::Result>,
+L<TAP::Parser::Grammar>
+
+=cut
diff --git a/lib/TAP/Parser/Scheduler.pm b/lib/TAP/Parser/Scheduler.pm
new file mode 100644 (file)
index 0000000..e0dea76
--- /dev/null
@@ -0,0 +1,243 @@
+package TAP::Parser::Scheduler;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+use TAP::Parser::Scheduler::Job;
+use TAP::Parser::Scheduler::Spinner;
+
+=head1 NAME
+
+TAP::Parser::Scheduler - Schedule tests during parallel testing
+
+=head1 VERSION
+
+Version 3.13
+
+=cut
+
+$VERSION = '3.13';
+
+=head1 SYNOPSIS
+
+    use TAP::Parser::Scheduler;
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+    my $sched = TAP::Parser::Scheduler->new;
+
+Returns a new C<TAP::Parser::Scheduler> object.
+
+=cut
+
+sub new {
+    my $class = shift;
+
+    croak "Need a number of key, value pairs" if @_ % 2;
+
+    my %args  = @_;
+    my $tests = delete $args{tests} || croak "Need a 'tests' argument";
+    my $rules = delete $args{rules} || { par => '**' };
+
+    croak "Unknown arg(s): ", join ', ', sort keys %args
+      if keys %args;
+
+    # Turn any simple names into a name, description pair. TODO: Maybe
+    # construct jobs here?
+    my $self = bless {}, $class;
+
+    $self->_set_rules( $rules, $tests );
+
+    return $self;
+}
+
+# Build the scheduler data structure.
+#
+# SCHEDULER-DATA ::= JOB
+#                ||  ARRAY OF ARRAY OF SCHEDULER-DATA
+#
+# The nested arrays are the key to scheduling. The outer array contains
+# a list of things that may be executed in parallel. Whenever an
+# eligible job is sought any element of the outer array that is ready to
+# execute can be selected. The inner arrays represent sequential
+# execution. They can only proceed when the first job is ready to run.
+
+sub _set_rules {
+    my ( $self, $rules, $tests ) = @_;
+    my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) }
+      map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
+    my $schedule = $self->_rule_clause( $rules, \@tests );
+
+    # If any tests are left add them as a sequential block at the end of
+    # the run.
+    $schedule = [ [ $schedule, @tests ] ] if @tests;
+
+    $self->{schedule} = $schedule;
+}
+
+sub _rule_clause {
+    my ( $self, $rule, $tests ) = @_;
+    croak 'Rule clause must be a hash'
+      unless 'HASH' eq ref $rule;
+
+    my @type = keys %$rule;
+    croak 'Rule clause must have exactly one key'
+      unless @type == 1;
+
+    my %handlers = (
+        par => sub {
+            [ map { [$_] } @_ ];
+        },
+        seq => sub { [ [@_] ] },
+    );
+
+    my $handler = $handlers{ $type[0] }
+      || croak 'Unknown scheduler type: ', $type[0];
+    my $val = $rule->{ $type[0] };
+
+    return $handler->(
+        map {
+            'HASH' eq ref $_
+              ? $self->_rule_clause( $_, $tests )
+              : $self->_expand( $_, $tests )
+          } 'ARRAY' eq ref $val ? @$val : $val
+    );
+}
+
+sub _expand {
+    my ( $self, $name, $tests ) = @_;
+
+    $name =~ s{(\?|\*\*?|.)}{
+        $1 eq '?'  ? '[^/]'
+      : $1 eq '*'  ? '[^/]*'
+      : $1 eq '**' ? '.*?'
+      :             quotemeta($1);
+    }gex;
+
+    my $pattern = qr{^$name$};
+    my @match   = ();
+
+    for ( my $ti = 0; $ti < @$tests; $ti++ ) {
+        if ( $tests->[$ti]->filename =~ $pattern ) {
+            push @match, splice @$tests, $ti, 1;
+            $ti--;
+        }
+    }
+
+    return @match;
+}
+
+=head3 C<get_all>
+
+Get a list of all remaining tests.
+
+=cut
+
+sub get_all {
+    my $self = shift;
+    $self->_gather( $self->{schedule} );
+}
+
+sub _gather {
+    my ( $self, $rule ) = @_;
+    return unless defined $rule;
+    return $rule unless 'ARRAY' eq ref $rule;
+    return map { $self->_gather($_) } grep {defined} map {@$_} @$rule;
+}
+
+=head3 C<get_job>
+
+Return the next available job or C<undef> if none are available. Returns
+a C<TAP::Parser::Scheduler::Spinner> if the scheduler still has pending
+jobs but none are available to run right now.
+
+=cut
+
+sub get_job {
+    my $self = shift;
+    my @jobs = $self->_find_next_job( $self->{schedule} );
+    return $jobs[0] if @jobs;
+
+    # TODO: This isn't very efficient...
+    return TAP::Parser::Scheduler::Spinner->new
+      if $self->get_all;
+
+    return;
+}
+
+sub _not_empty {
+    my $ar = shift;
+    return 1 unless defined $ar && 'ARRAY' eq ref $ar;
+    return 1 if grep { _not_empty($_) } @$ar;
+    return;
+}
+
+sub _is_empty { !_not_empty(@_) }
+
+sub _find_next_job {
+    my ( $self, $rule ) = @_;
+
+    my @queue = ();
+    for my $seq (@$rule) {
+
+        # Prune any exhausted items.
+        shift @$seq while @$seq && _is_empty( $seq->[0] );
+        if ( @$seq && defined $seq->[0] ) {
+            if ( 'ARRAY' eq ref $seq->[0] ) {
+                push @queue, $seq;
+            }
+            else {
+                my $job = splice @$seq, 0, 1, undef;
+                $job->on_finish( sub { shift @$seq } );
+                return $job;
+            }
+        }
+    }
+
+    for my $seq (@queue) {
+        if ( my @jobs = $self->_find_next_job( $seq->[0] ) ) {
+            return @jobs;
+        }
+    }
+
+    return;
+}
+
+=head3 C<as_string>
+
+Return a human readable representation of the scheduling tree.
+
+=cut
+
+sub as_string {
+    my $self = shift;
+    return $self->_as_string( $self->{schedule} );
+}
+
+sub _as_string {
+    my ( $self, $rule, $depth ) = ( shift, shift, shift || 0 );
+    my $pad    = ' ' x 2;
+    my $indent = $pad x $depth;
+    if ( !defined $rule ) {
+        return "$indent(undef)\n";
+    }
+    elsif ( 'ARRAY' eq ref $rule ) {
+        return unless @$rule;
+        my $type = ( 'par', 'seq' )[ $depth % 2 ];
+        return join(
+            '', "$indent$type:\n",
+            map { $self->_as_string( $_, $depth + 1 ) } @$rule
+        );
+    }
+    else {
+        return "$indent'" . $rule->filename . "'\n";
+    }
+}
+
+1;
diff --git a/lib/TAP/Parser/Scheduler/Job.pm b/lib/TAP/Parser/Scheduler/Job.pm
new file mode 100644 (file)
index 0000000..2dc05e0
--- /dev/null
@@ -0,0 +1,107 @@
+package TAP::Parser::Scheduler::Job;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+=head1 NAME
+
+TAP::Parser::Scheduler::Job - A single testing job.
+
+=head1 VERSION
+
+Version 3.13
+
+=cut
+
+$VERSION = '3.13';
+
+=head1 SYNOPSIS
+
+    use TAP::Parser::Scheduler::Job;
+
+=head1 DESCRIPTION
+
+Represents a single test 'job'.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+    my $job = TAP::Parser::Scheduler::Job->new(
+        $name, $desc 
+    );
+
+Returns a new C<TAP::Parser::Scheduler::Job> object.
+
+=cut
+
+sub new {
+    my ( $class, $name, $desc, @ctx ) = @_;
+    return bless {
+        filename    => $name,
+        description => $desc,
+        context     => \@ctx,
+    }, $class;
+}
+
+=head3 C<on_finish>
+
+Register a closure to be called when this job is destroyed.
+
+=cut
+
+sub on_finish {
+    my ( $self, $cb ) = @_;
+    $self->{on_finish} = $cb;
+}
+
+=head3 C<finish>
+
+Called when a job is complete to unlock it.
+
+=cut
+
+sub finish {
+    my $self = shift;
+    if ( my $cb = $self->{on_finish} ) {
+        $cb->($self);
+    }
+}
+
+=head3 C<filename>
+
+=head3 C<description>
+
+=head3 C<context>
+
+=cut
+
+sub filename    { shift->{filename} }
+sub description { shift->{description} }
+sub context     { @{ shift->{context} } }
+
+=head3 C<as_array_ref>
+
+For backwards compatibility in callbacks.
+
+=cut
+
+sub as_array_ref {
+    my $self = shift;
+    return [ $self->filename, $self->description, $self->context ];
+}
+
+=head3 C<is_spinner>
+
+Returns false indicating that this is a real job rather than a
+'spinner'. Spinners are returned when the scheduler still has pending
+jobs but can't (because of locking) return one right now.
+
+=cut
+
+sub is_spinner {0}
+
+1;
diff --git a/lib/TAP/Parser/Scheduler/Spinner.pm b/lib/TAP/Parser/Scheduler/Spinner.pm
new file mode 100644 (file)
index 0000000..6a0fa60
--- /dev/null
@@ -0,0 +1,53 @@
+package TAP::Parser::Scheduler::Spinner;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+=head1 NAME
+
+TAP::Parser::Scheduler::Spinner - A no-op job.
+
+=head1 VERSION
+
+Version 3.13
+
+=cut
+
+$VERSION = '3.13';
+
+=head1 SYNOPSIS
+
+    use TAP::Parser::Scheduler::Spinner;
+
+=head1 DESCRIPTION
+
+A no-op job. Returned by C<TAP::Parser::Scheduler> as an instruction to
+the harness to spin (keep executing tests) while the scheduler can't
+return a real job.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+    my $job = TAP::Parser::Scheduler::Spinner->new;
+
+Returns a new C<TAP::Parser::Scheduler::Spinner> object.
+
+=cut
+
+sub new { bless {}, shift }
+
+=head3 C<is_spinner>
+
+Returns true indicating that is a 'spinner' job. Spinners are returned
+when the scheduler still has pending jobs but can't (because of locking)
+return one right now.
+
+=cut
+
+sub is_spinner {1}
+
+1;
index a78a583..9fc97a9 100644 (file)
@@ -1,9 +1,12 @@
 package TAP::Parser::Source;
 
 use strict;
-use vars qw($VERSION);
+use vars qw($VERSION @ISA);
 
-use TAP::Parser::Iterator ();
+use TAP::Object                  ();
+use TAP::Parser::IteratorFactory ();
+
+@ISA = qw(TAP::Object);
 
 # Causes problem on MacOS and shouldn't be necessary anyway
 #$SIG{CHLD} = sub { wait };
@@ -14,21 +17,21 @@ TAP::Parser::Source - Stream output from some source
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
-=head1 DESCRIPTION
+=head1 SYNOPSIS
 
-Takes a command and hopefully returns a stream from it.
+  use TAP::Parser::Source;
+  my $source = TAP::Parser::Source->new;
+  my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream;
 
-=head1 SYNOPSIS
+=head1 DESCRIPTION
 
- use TAP::Parser::Source;
- my $source = TAP::Parser::Source->new;
- my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream;
+Takes a command and hopefully returns a stream from it.
 
 =head1 METHODS
 
@@ -42,11 +45,14 @@ Returns a new C<TAP::Parser::Source> object.
 
 =cut
 
-sub new {
-    my $class = shift;
+# new() implementation supplied by TAP::Object
+
+sub _initialize {
+    my ( $self, $args ) = @_;
+    $self->{switches} = [];
     _autoflush( \*STDOUT );
     _autoflush( \*STDERR );
-    bless { switches => [] }, $class;
+    return $self;
 }
 
 ##############################################################################
@@ -62,8 +68,9 @@ sub new {
  $source->source(['/usr/bin/ruby', 't/ruby_test.rb']);
 
 Getter/setter for the source.  The source should generally consist of an array
-reference of strings which, when executed via L<&IPC::Open3::open3|IPC::Open3>, should
-return a filehandle which returns successive rows of TAP.
+reference of strings which, when executed via L<&IPC::Open3::open3|IPC::Open3>,
+should return a filehandle which returns successive rows of TAP.  C<croaks> if
+it doesn't get an arrayref.
 
 =cut
 
@@ -83,16 +90,20 @@ sub source {
 
  my $stream = $source->get_stream;
 
-Returns a stream of the output generated by executing C<source>.
+Returns a L<TAP::Parser::Iterator> stream of the output generated by executing
+C<source>.  C<croak>s if there was no command found.
+
+Must be passed an object that implements a C<make_iterator> method.
+Typically this is a TAP::Parser instance.
 
 =cut
 
 sub get_stream {
-    my ($self) = @_;
+    my ( $self, $factory ) = @_;
     my @command = $self->_get_command
       or $self->_croak('No command found!');
 
-    return TAP::Parser::Iterator->new(
+    return $factory->make_iterator(
         {   command => \@command,
             merge   => $self->merge
         }
@@ -103,43 +114,6 @@ sub _get_command { return @{ shift->source || [] } }
 
 ##############################################################################
 
-=head3 C<error>
-
- unless ( my $stream = $source->get_stream ) {
-     die $source->error;
- }
-
-If a stream cannot be created, this method will return the error.
-
-=cut
-
-sub error {
-    my $self = shift;
-    return $self->{error} unless @_;
-    $self->{error} = shift;
-    return $self;
-}
-
-##############################################################################
-
-=head3 C<exit>
-
-  my $exit = $source->exit;
-
-Returns the exit status of the process I<if and only if> an error occurs in
-opening the file.
-
-=cut
-
-sub exit {
-    my $self = shift;
-    return $self->{exit} unless @_;
-    $self->{exit} = shift;
-    return $self;
-}
-
-##############################################################################
-
 =head3 C<merge>
 
   my $merge = $source->merge;
@@ -163,10 +137,37 @@ sub _autoflush {
     select $old_fh;
 }
 
-sub _croak {
-    my $self = shift;
-    require Carp;
-    Carp::croak(@_);
-}
-
 1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+  package MyRubySource;
+
+  use strict;
+  use vars '@ISA';
+
+  use Carp qw( croak );
+  use TAP::Parser::Source;
+
+  @ISA = qw( TAP::Parser::Source );
+
+  # expect $source->(['mytest.rb', 'cmdline', 'args']);
+  sub source {
+    my ($self, $args) = @_;
+    my ($rb_file) = @$args;
+    croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file);
+    return $self->SUPER::source(['/usr/bin/ruby', @$args]);
+  }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source::Perl>,
+
+=cut
+
index 7e5036d..fd60a76 100644 (file)
@@ -16,11 +16,17 @@ TAP::Parser::Source::Perl - Stream Perl output
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::Source::Perl;
+  my $perl = TAP::Parser::Source::Perl->new;
+  my $stream = $perl->source( [ $filename, @args ] )->get_stream;
 
 =head1 DESCRIPTION
 
@@ -30,12 +36,6 @@ be the name of a Perl program.
 Note that this is a subclass of L<TAP::Parser::Source>.  See that module for
 more methods.
 
-=head1 SYNOPSIS
-
-    use TAP::Parser::Source::Perl;
-    my $perl = TAP::Parser::Source::Perl->new;
-    my $stream = $perl->source( [ $filename, @args ] )->get_stream;
-
 =head1 METHODS
 
 =head2 Class Methods
@@ -55,6 +55,8 @@ Getter/setter the name of the test program and any arguments it requires.
   my ($filename, @args) = @{ $perl->source };
   $perl->source( [ $filename, @args ] );
 
+C<croak>s if C<$filename> could not be found.
+
 =cut
 
 sub source {
@@ -91,14 +93,16 @@ sub switches {
 
 =head3 C<get_stream>
 
my $stream = $source->get_stream;
 my $stream = $source->get_stream($parser);
 
-Returns a stream of the output generated by executing C<source>.
+Returns a stream of the output generated by executing C<source>. Must be
+passed an object that implements a C<make_iterator> method. Typically
+this is a TAP::Parser instance.
 
 =cut
 
 sub get_stream {
-    my $self = shift;
+    my ( $self, $factory ) = @_;
 
     my @extra_libs;
 
@@ -154,7 +158,7 @@ sub get_stream {
     my @command = $self->_get_command_for_switches(@switches)
       or $self->_croak("No command found!");
 
-    return TAP::Parser::Iterator->new(
+    return $factory->make_iterator(
         {   command  => \@command,
             merge    => $self->merge,
             setup    => $setup,
@@ -169,7 +173,8 @@ sub _get_command_for_switches {
     my ( $file, @args ) = @{ $self->source };
     my $command = $self->_get_perl;
 
-    $file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
+# XXX we never need to quote if we treat the parts as atoms (except maybe vms)
+#$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
     my @command = ( $command, @switches, $file, @args );
     return @command;
 }
@@ -188,7 +193,7 @@ sub _libs2switches {
 
 Get the shebang line for a script file.
 
-    my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
+  my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
 
 May be called as a class method
 
@@ -226,11 +231,11 @@ May be called as a class method
 
 Decode any taint switches from a Perl shebang line.
 
-    # $taint will be 't'
-    my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
+  # $taint will be 't'
+  my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
 
-    # $untaint will be undefined
-    my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );    
+  # $untaint will be undefined
+  my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
 
 =cut
 
@@ -266,10 +271,53 @@ sub _switches {
 }
 
 sub _get_perl {
-    my $proto = shift;
+    my $self = shift;
     return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
     return Win32::GetShortPathName($^X) if IS_WIN32;
     return $^X;
 }
 
 1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+  package MyPerlSource;
+
+  use strict;
+  use vars '@ISA';
+
+  use Carp qw( croak );
+  use TAP::Parser::Source::Perl;
+
+  @ISA = qw( TAP::Parser::Source::Perl );
+
+  sub source {
+      my ($self, $args) = @_;
+      if ($args) {
+         $self->{file} = $args->[0];
+         return $self->SUPER::source($args);
+      }
+      return $self->SUPER::source;
+  }
+
+  # use the version of perl from the shebang line in the test file
+  sub _get_perl {
+      my $self = shift;
+      if (my $shebang = $self->shebang( $self->{file} )) {
+          $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
+         return $1 if $1;
+      }
+      return $self->SUPER::_get_perl(@_);
+  }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source>,
+
+=cut
index c716e01..837c63e 100644 (file)
@@ -13,11 +13,11 @@ TAP::Parser::Utils - Internal TAP::Parser utilities
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 =head1 SYNOPSIS
 
index 126f7b5..fca56de 100644 (file)
@@ -1,10 +1,12 @@
 package TAP::Parser::YAMLish::Reader;
 
 use strict;
+use vars qw($VERSION @ISA);
 
-use vars qw{$VERSION};
+use TAP::Object ();
 
-$VERSION = '3.10';
+@ISA     = 'TAP::Object';
+$VERSION = '3.13';
 
 # TODO:
 #   Handle blessed object syntax
@@ -17,16 +19,12 @@ my %UNESCAPES = (
 );
 
 my $QQ_STRING    = qr{ " (?:\\. | [^"])* " }x;
-my $HASH_LINE    = qr{ ^ ($QQ_STRING|\S+) \s* : (?: \s+ (.+?) \s* )? $ }x;
+my $HASH_LINE    = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x;
 my $IS_HASH_KEY  = qr{ ^ [\w\'\"] }x;
 my $IS_END_YAML  = qr{ ^ \.\.\. \s* $ }x;
 my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x;
 
-# Create an empty TAP::Parser::YAMLish::Reader object
-sub new {
-    my $class = shift;
-    bless {}, $class;
-}
+# new() implementation supplied by TAP::Object
 
 sub read {
     my $self = shift;
@@ -40,6 +38,7 @@ sub read {
 
     #┬áPrime the reader
     $self->_next;
+    return unless $self->{next};
 
     my $doc = $self->_read;
 
@@ -58,15 +57,7 @@ sub read {
     return $doc;
 }
 
-sub get_raw {
-    my $self = shift;
-
-    if ( defined( my $capture = $self->{capture} ) ) {
-        return join( "\n", @$capture ) . "\n";
-    }
-
-    return '';
-}
+sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" }
 
 sub _peek {
     my $self = shift;
@@ -151,7 +142,9 @@ sub _read_scalar {
             $self->_next;
             my ( $next, $ind ) = $self->_peek;
             last if $ind < $indent;
-            push @multiline, $next;
+
+            my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : '';
+            push @multiline, $pad . $next;
         }
 
         return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n";
@@ -277,7 +270,7 @@ TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =head1 SYNOPSIS
 
index 214be52..5889ac1 100644 (file)
@@ -1,10 +1,12 @@
 package TAP::Parser::YAMLish::Writer;
 
 use strict;
+use vars qw($VERSION @ISA);
 
-use vars qw{$VERSION};
+use TAP::Object ();
 
-$VERSION = '3.10';
+@ISA     = 'TAP::Object';
+$VERSION = '3.13';
 
 my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
 my $ESCAPE_KEY  = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
@@ -16,11 +18,7 @@ my @UNPRINTABLE = qw(
   x18  x19  x1a  e    x1c  x1d  x1e  x1f
 );
 
-# Create an empty TAP::Parser::YAMLish::Writer object
-sub new {
-    my $class = shift;
-    bless {}, $class;
-}
+# new() implementation supplied by TAP::Object
 
 sub write {
     my $self = shift;
@@ -149,7 +147,7 @@ TAP::Parser::YAMLish::Writer - Write YAMLish data
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =head1 SYNOPSIS
 
index 17e8916..4f0164e 100644 (file)
@@ -28,6 +28,7 @@ use vars qw(
   $Timer
   $Strap
   $has_time_hires
+  $IgnoreExit
 );
 
 # $ML $Last_ML_Print
@@ -43,11 +44,11 @@ Test::Harness - Run Perl standard test scripts with statistics
 
 =head1 VERSION
 
-Version 3.10
+Version 3.13
 
 =cut
 
-$VERSION = '3.10';
+$VERSION = '3.13';
 
 # Backwards compatibility for exportable variable names.
 *verbose  = *Verbose;
@@ -73,8 +74,9 @@ $Debug   = $ENV{HARNESS_DEBUG}   || 0;
 $Switches = '-w';
 $Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
 $Columns--;    # Some shells have trouble with a full line of text.
-$Timer = $ENV{HARNESS_TIMER} || 0;
-$Color = $ENV{HARNESS_COLOR} || 0;
+$Timer      = $ENV{HARNESS_TIMER}       || 0;
+$Color      = $ENV{HARNESS_COLOR}       || 0;
+$IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0;
 
 =head1 SYNOPSIS
 
@@ -225,9 +227,7 @@ sub _new_harness {
     my $sub_args = shift || {};
 
     my ( @lib, @switches );
-    for my $opt (
-        split_shell( $Switches, $ENV{HARNESS_PERL_SWITCHES} ) )
-    {
+    for my $opt ( split_shell( $Switches, $ENV{HARNESS_PERL_SWITCHES} ) ) {
         if ( $opt =~ /^ -I (.*) $ /x ) {
             push @lib, $1;
         }
@@ -243,12 +243,13 @@ sub _new_harness {
     my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 );
 
     my $args = {
-        timer      => $Timer,
-        directives => $Directives,
-        lib        => \@lib,
-        switches   => \@switches,
-        color      => $Color,
-        verbosity  => $verbosity,
+        timer       => $Timer,
+        directives  => $Directives,
+        lib         => \@lib,
+        switches    => \@switches,
+        color       => $Color,
+        verbosity   => $verbosity,
+        ignore_exit => $IgnoreExit,
     };
 
     $args->{stdout} = $sub_args->{out}
index ff7eee0..2051eab 100644 (file)
@@ -1,6 +1,65 @@
 Revision history for Test-Harness
 
-3.07   2008-01-13
+3.13    2008-07-27
+        - fixed various closure related leaks
+        - made prove honour HARNESS_TIMER
+        - Applied patches supplied by Alex Vandiver
+          - add 'rules' switch to prove: allows parallel execution rules
+            to be specified on the command line.
+          - allow '**' (any path) wildcard in parallel rules
+          - fix bug report address
+          - make tprove_gtk example work again.
+
+3.12    2008-06-22
+        - applied Steve Purkis' huge refactoring patch which adds
+          configurable factories for most of the major internal classes.
+        - applied David Wheeler's patch to allow exec to be a code
+          reference.
+        - made tests more robust in the presence of -MFoo in PERL5OPT.
+
+3.11    2008-06-09
+        - applied Jim Keenan's patch that makes App::Prove::run return a
+          rather than exit (#33609)
+        - prove -r now recurses cwd rather than 't' by default (#33007)
+        - restored --ext switch to prove (#33848)
+        - added ignore_exit option to TAP::Parser and corresponding
+          interfaces to TAP::Harness and Test::Harness. Requested for
+          Parrot.
+        - Implemented rule based parallel scheduler.
+        - Moved filename -> display name mapping out of formatter. This
+          prevents the formatter's strip-extensions logic from stripping
+          extensions from supplied descriptions.
+        - Only strip extensions from test names if all tests have the
+          same extension. Previously we stripped extensions if all names
+          had /any/ extension making it impossible to distinguish tests
+          whose name differed only in the extension.
+        - Removed privacy test that made it impossible to subclass
+          TAP::Parser.
+        - Delayed initialisation of grammar making it easier to replace
+          the TAP::Parser stream after instantiation.
+        - Make it possible to supply import parameters to a replacement
+          harness with prove.
+        - Make it possible to replace either _grammar /or/ _stream
+          before reading from a TAP::Parser.
+
+3.10    2008-02-26
+        - fix undefined value warnings with bleadperl.
+        - added pragma support.
+        - fault unknown TAP tokens under strict pragma.
+
+3.09    2008-02-10
+        - support for HARNESS_PERL_SWITCHES containing things like 
+          '-e "system(shift)"'.
+        - set HARNESS_IS_VERBOSE during verbose testing.
+        - documentation fixes.
+
+3.08    2008-02-08
+        - added support for 'out' option to
+          Test::Harness::execute_tests. See #32476. Thanks RENEEB.
+        - Fixed YAMLish handling of non-alphanumeric hash keys.
+        - Added --dry option to prove for 2.64 compatibility.
+
+3.07    2008-01-13
         - prove now supports HARNESS_PERL_SWITCHES.
         - restored TEST_VERBOSE to prove.
 
index acd845a..ee31df8 100644 (file)
@@ -5,7 +5,7 @@ use App::Prove;
 
 my $app = App::Prove->new;
 $app->process_args(@ARGV);
-$app->run;
+exit( $app->run ? 0 : 1 );
 
 __END__
 
@@ -23,13 +23,15 @@ Boolean options:
 
  -v,  --verbose     Print all test lines.
  -l,  --lib         Add 'lib' to the path for your tests (-Ilib).
- -b,  --blib        Add 'blib/lib' to the path for your tests (-Iblib/lib).
+ -b,  --blib        Add 'blib/lib' and 'blib/arch' to the path for your tests
  -s,  --shuffle     Run the tests in random order.
  -c,  --color       Colored test output (default).
       --nocolor     Do not color test output.
  -D   --dry         Dry run. Show test that would have run.
+      --ext         Set the extension for tests (default '.t')
  -f,  --failures    Only show failed tests.
-      --fork        Fork to run harness in multiple processes
+      --fork        Fork to run harness in multiple processes.
+      --ignore-exit Ignore exit status from test scripts.
  -m,  --merge       Merge test scripts' STDERR with their STDOUT.
  -r,  --recurse     Recursively descend into directories.
       --reverse     Run the tests in reverse order.
index 5c952a7..c6d6a92 100644 (file)
@@ -3,7 +3,7 @@
 use strict;
 use lib 't/lib';
 
-use Test::More tests => 62;
+use Test::More tests => 74;
 
 BEGIN {
 
@@ -20,11 +20,14 @@ BEGIN {
       TAP::Harness
       TAP::Parser::Aggregator
       TAP::Parser::Grammar
+      TAP::Parser::Iterator
       TAP::Parser::Iterator::Array
       TAP::Parser::Iterator::Process
       TAP::Parser::Iterator::Stream
-      TAP::Parser::Iterator
+      TAP::Parser::IteratorFactory
       TAP::Parser::Multiplexer
+      TAP::Parser::Result
+      TAP::Parser::ResultFactory
       TAP::Parser::Result::Bailout
       TAP::Parser::Result::Comment
       TAP::Parser::Result::Plan
@@ -34,6 +37,9 @@ BEGIN {
       TAP::Parser::Result::Version
       TAP::Parser::Result::YAML
       TAP::Parser::Result
+      TAP::Parser::Scheduler
+      TAP::Parser::Scheduler::Job
+      TAP::Parser::Scheduler::Spinner
       TAP::Parser::Source::Perl
       TAP::Parser::Source
       TAP::Parser::YAMLish::Reader
index 441e2ba..b3aff2a 100644 (file)
@@ -1,13 +1,12 @@
 #!/usr/bin/perl -wT
 
-
 use strict;
 use lib 't/lib';
 
 use Test::More tests => 79;
 
 use TAP::Parser;
-use TAP::Parser::Iterator;
+use TAP::Parser::IteratorFactory;
 use TAP::Parser::Aggregator;
 
 my $tap = <<'END_TAP';
@@ -21,7 +20,8 @@ not ok 4 - this is a real failure
 ok 5 # skip we have no description
 END_TAP
 
-my $stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] );
+my $factory = TAP::Parser::IteratorFactory->new;
+my $stream = $factory->make_iterator( [ split /\n/ => $tap ] );
 isa_ok $stream, 'TAP::Parser::Iterator';
 
 my $parser1 = TAP::Parser->new( { stream => $stream } );
@@ -207,12 +207,9 @@ is $agg->todo_passed, 1,
   '... and the correct number of unexpectedly succeeded tests';
 ok $agg->has_problems,
   '... and it should report true that there are problems';
-is $agg->get_status, 'PASS',
-  '... and the status should be passing';
-ok !$agg->has_errors,
-  '.... but it should not report any errors';
-ok $agg->all_passed,
-  '... bonus tests should be passing tests, too';
+is $agg->get_status, 'PASS', '... and the status should be passing';
+ok !$agg->has_errors, '.... but it should not report any errors';
+ok $agg->all_passed, '... bonus tests should be passing tests, too';
 
 # 2. !failed && !todo_passed && parse_errors
 
index 25197f6..4fee548 100644 (file)
@@ -89,8 +89,8 @@ package main;
     ok( !$@, 'callbacks installed OK' );
 
     my $nice_cbs = $base->_callback_for('nice_event');
-    is( ref $nice_cbs, 'ARRAY', 'callbacks type ok' );
-    is( scalar @$nice_cbs, 1, 'right number of callbacks' );
+    is( ref $nice_cbs,     'ARRAY', 'callbacks type ok' );
+    is( scalar @$nice_cbs, 1,       'right number of callbacks' );
     my $nice_cb = $nice_cbs->[0];
     ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' );
     my $got = $nice_cb->('Is ');
@@ -98,16 +98,16 @@ package main;
     cmp_ok( $nice, '==', 1, 'callback calls the right sub' );
 
     my $other_cbs = $base->_callback_for('other_event');
-    is( ref $other_cbs, 'ARRAY', 'callbacks type ok' );
-    is( scalar @$other_cbs, 1, 'right number of callbacks' );
+    is( ref $other_cbs,     'ARRAY', 'callbacks type ok' );
+    is( scalar @$other_cbs, 1,       'right number of callbacks' );
     my $other_cb = $other_cbs->[0];
     ok( ref $other_cb eq 'CODE', 'callback for other_event returned' );
     $other_cb->();
     cmp_ok( $other, '==', -1, 'callback calls the right sub' );
 
     my @got = $base->_make_callback( 'nice_event', 'I am ' );
-    is( scalar @got, 1, 'right number of results' );
-    is( $got[0], 'I am OK', 'callback via _make_callback works' );
+    is( scalar @got, 1,         'right number of results' );
+    is( $got[0],     'I am OK', 'callback via _make_callback works' );
 }
 
 {
@@ -139,16 +139,16 @@ package main;
     ok( !$@, 'callback installed OK' );
 
     my $nice_cbs = $base->_callback_for('nice_event');
-    is( ref $nice_cbs, 'ARRAY', 'callbacks type ok' );
-    is( scalar @$nice_cbs, 1, 'right number of callbacks' );
+    is( ref $nice_cbs,     'ARRAY', 'callbacks type ok' );
+    is( scalar @$nice_cbs, 1,       'right number of callbacks' );
     my $nice_cb = $nice_cbs->[0];
     ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' );
     $nice_cb->();
     cmp_ok( $nice, '==', 1, 'callback calls the right sub' );
 
     my $other_cbs = $base->_callback_for('other_event');
-    is( ref $other_cbs, 'ARRAY', 'callbacks type ok' );
-    is( scalar @$other_cbs, 1, 'right number of callbacks' );
+    is( ref $other_cbs,     'ARRAY', 'callbacks type ok' );
+    is( scalar @$other_cbs, 1,       'right number of callbacks' );
     my $other_cb = $other_cbs->[0];
     ok( ref $other_cb eq 'CODE', 'callback for other_event returned' );
     $other_cb->();
@@ -164,8 +164,8 @@ package main;
     $base->callback( other_event => sub { $status = 'OK'; return 'Aye' } );
 
     my $new_cbs = $base->_callback_for('other_event');
-    is( ref $new_cbs, 'ARRAY', 'callbacks type ok' );
-    is( scalar @$new_cbs, 2, 'right number of callbacks' );
+    is( ref $new_cbs,     'ARRAY', 'callbacks type ok' );
+    is( scalar @$new_cbs, 2,       'right number of callbacks' );
     my $new_cb = $new_cbs->[1];
     ok( ref $new_cb eq 'CODE', 'callback for new_event returned' );
     my @got = $new_cb->();
index b237621..9d0cae4 100644 (file)
@@ -6,7 +6,7 @@ use lib 't/lib';
 use Test::More tests => 10;
 
 use TAP::Parser;
-use TAP::Parser::Iterator;
+use TAP::Parser::IteratorFactory;
 
 my $tap = <<'END_TAP';
 1..5
@@ -36,8 +36,9 @@ my %callbacks = (
     }
 );
 
-my $stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] );
-my $parser = TAP::Parser->new(
+my $factory = TAP::Parser::IteratorFactory->new;
+my $stream  = $factory->make_iterator( [ split /\n/ => $tap ] );
+my $parser  = TAP::Parser->new(
     {   stream    => $stream,
         callbacks => \%callbacks,
     }
@@ -77,7 +78,7 @@ my $end  = 0;
     },
 );
 
-$stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] );
+$stream = $factory->make_iterator( [ split /\n/ => $tap ] );
 $parser = TAP::Parser->new(
     {   stream    => $stream,
         callbacks => \%callbacks,
@@ -102,7 +103,7 @@ is $end,  1, 'EOF callback correctly called';
     ELSES    => sub { },
 );
 
-$stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] );
+$stream = $factory->make_iterator( [ split /\n/ => $tap ] );
 eval {
     $parser = TAP::Parser->new(
         {   stream    => $stream,
index 564297c..ffa5370 100644 (file)
@@ -22,60 +22,28 @@ use Test::More (
     : ( tests => 2 )
 );
 
-use Data::Dumper;
 use Test::Harness;
 
 # Change @INC so we ensure it's preserved.
 use lib 'wibble';
 
-# TODO: Disabled until we find out why it's breaking on Windows. It's
-# not strictly a TODO because it seems pretty likely that it's a Windows
-# problem rather than a problem with Test::Harness.
-
-# Put a stock directory near the beginning.
-# use lib $INC[$#INC-2];
-
-my $inc = Data::Dumper->new( [ \@INC ] )->Terse(1)->Purity(1)->Dump;
-my $taint_inc
-  = Data::Dumper->new( [ [ grep { $_ ne '.' } @INC ] ] )->Terse(1)->Purity(1)
-  ->Dump;
-
-# The tail of @INC is munged during core testing. We're only *really*
-# interested in whether 'wibble' makes it anyway.
-my $cmp_slice = $ENV{PERL_CORE} ? '[0..1]' : '';
-
 my $test_template = <<'END';
 #!/usr/bin/perl %s
 
 use Test::More tests => 2;
 
-sub _strip_dups {
-    my %%dups;
-    # Drop '.' which sneaks in on some platforms
-    my @r = grep { $_ ne '.' } grep { !$dups{$_}++ } @_;
-    return @r%s;
-}
-
 # Make sure we did something sensible with PERL5LIB
 like $ENV{PERL5LIB}, qr{wibble};
+ok grep { $_ eq 'wibble' } @INC;
 
-is_deeply(
-    [_strip_dups(@INC)],
-    [_strip_dups(@{%s})],
-    '@INC propagated to test'
-) or do {
-    diag join ",\n", _strip_dups(@INC);
-    diag '-----------------';
-    diag join ",\n", _strip_dups(@{%s});
-};
 END
 
 open TEST, ">inc_check.t.tmp";
-printf TEST $test_template, '', $cmp_slice, $inc, $inc;
+printf TEST $test_template, '';
 close TEST;
 
 open TEST, ">inc_check_taint.t.tmp";
-printf TEST $test_template, '-T', $cmp_slice, $taint_inc, $taint_inc;
+printf TEST $test_template, '-T';
 close TEST;
 END { 1 while unlink 'inc_check_taint.t.tmp', 'inc_check.t.tmp'; }
 
index f0101c3..06a8e23 100644 (file)
@@ -1,12 +1,12 @@
 #!/usr/bin/perl -w
 
 BEGIN {
-    if( $ENV{PERL_CORE} ) {
+    if ( $ENV{PERL_CORE} ) {
         chdir 't';
-        @INC = ('../lib', 'lib');
+        @INC = ( '../lib', 'lib' );
     }
     else {
-       use lib 't/lib';
+        use lib 't/lib';
     }
 }
 
index d8105c9..1d848f9 100644 (file)
@@ -7,6 +7,7 @@ use Test::More tests => 1;
 use Test::Harness;
 
 {
+
     #28567
     unshift @INC, 'wibble';
     my @before = Test::Harness::_filtered_inc();
index 5709d7a..480d6d8 100644 (file)
@@ -9,6 +9,7 @@ BEGIN {
 }
 
 use strict;
+
 use lib 't/lib';
 
 use Test::More;
@@ -52,7 +53,7 @@ local $ENV{HARNESS_PERL_SWITCHES};
               head_end head_fail inc_taint junk_before_plan lone_not_bug
               no_nums no_output schwern sequence_misparse shbang_misparse
               simple simple_fail skip skip_nomsg skipall skipall_nomsg
-              stdout_stderr switches taint todo_inline
+              stdout_stderr taint todo_inline
               todo_misparse too_many vms_nit
               )
           ) => {
@@ -129,14 +130,6 @@ local $ENV{HARNESS_PERL_SWITCHES};
                     'name'   => 't/sample-tests/simple_fail',
                     'wstat'  => ''
                 },
-                't/sample-tests/switches' => {
-                    'canon'  => 1,
-                    'estat'  => '',
-                    'failed' => 1,
-                    'max'    => 1,
-                    'name'   => 't/sample-tests/switches',
-                    'wstat'  => ''
-                },
                 't/sample-tests/todo_misparse' => {
                     'canon'  => 1,
                     'estat'  => '',
@@ -173,15 +166,15 @@ local $ENV{HARNESS_PERL_SWITCHES};
                 }
             },
             'totals' => {
-                'bad'         => 13,
+                'bad'         => 12,
                 'bonus'       => 1,
-                'files'       => 28,
+                'files'       => 27,
                 'good'        => 15,
-                'max'         => 77,
+                'max'         => 76,
                 'ok'          => 78,
                 'skipped'     => 2,
                 'sub_skipped' => 2,
-                'tests'       => 28,
+                'tests'       => 27,
                 'todo'        => 2
             }
           },
@@ -603,6 +596,9 @@ local $ENV{HARNESS_PERL_SWITCHES};
             }
         },
         'switches' => {
+            'skip_if' => sub {
+                ( $ENV{PERL5OPT} || '' ) =~ m{(?:^|\s)-[dM]};
+            },
             'failed' => {
                 't/sample-tests/switches' => {
                     'canon'  => 1,
@@ -814,6 +810,13 @@ local $ENV{HARNESS_PERL_SWITCHES};
             if ( $result->{require} && $] < $result->{require} ) {
                 skip "Test requires Perl $result->{require}, we have $]", 4;
             }
+
+            if ( my $skip_if = $result->{skip_if} ) {
+                skip
+                  "Test '$test_key' can't run properly in this environment", 4
+                  if $skip_if->();
+            }
+
             my @test_names = split( /,/, $test_key );
             my @test_files
               = map { File::Spec->catfile( $TEST_DIR, $_ ) } @test_names;
index 6d572f9..f1521ed 100644 (file)
@@ -1,10 +1,20 @@
 #!/usr/bin/perl -w
 
 use strict;
-use lib 't/lib';
+
+BEGIN {
+    if ( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ( '../lib', 'lib' );
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
 
 use Test::More tests => 94;
 
+use EmptyParser;
 use TAP::Parser::Grammar;
 use TAP::Parser::Iterator::Array;
 
@@ -33,8 +43,9 @@ sub handle_unicode { }
 package main;
 
 my $stream = SS->new;
+my $parser = EmptyParser->new;
 can_ok $GRAMMAR, 'new';
-my $grammar = $GRAMMAR->new($stream);
+my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } );
 isa_ok $grammar, $GRAMMAR, '... and the object it returns';
 
 # Note:  all methods are actually class methods.  See the docs for the reason
@@ -341,9 +352,9 @@ is_deeply $token, $expected,
 
 # tokenize
 {
-    my $stream = SS->new;
-
-    my $grammar = $GRAMMAR->new($stream);
+    my $stream  = SS->new;
+    my $parser  = EmptyParser->new;
+    my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } );
 
     my $plan = '';
 
@@ -357,7 +368,8 @@ is_deeply $token, $expected,
 # _make_plan_token
 
 {
-    my $grammar = $GRAMMAR->new;
+    my $parser = EmptyParser->new;
+    my $grammar = $GRAMMAR->new( { parser => $parser } );
 
     my $plan
       = '1..1 # SKIP with explanation';  # trigger warning in _make_plan_token
@@ -384,9 +396,9 @@ is_deeply $token, $expected,
 # _make_yaml_token
 
 {
-    my $stream = SS->new;
-
-    my $grammar = $GRAMMAR->new($stream);
+    my $stream  = SS->new;
+    my $parser  = EmptyParser->new;
+    my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } );
 
     $grammar->set_version(13);
 
index 484f210..70ff42e 100644 (file)
@@ -22,7 +22,7 @@ my $HARNESS = 'TAP::Harness';
 my $source_tests = $ENV{PERL_CORE} ? 'lib/source_tests' : 't/source_tests';
 my $sample_tests = $ENV{PERL_CORE} ? 'lib/sample-tests' : 't/sample-tests';
 
-plan tests => 106;
+plan tests => 113;
 
 # note that this test will always pass when run through 'prove'
 ok $ENV{HARNESS_ACTIVE},  'HARNESS_ACTIVE env variable should be set';
@@ -536,6 +536,27 @@ SKIP: {
     is( $answer, "All tests successful.\n", 'cat meows' );
 }
 
+# make sure that we can exec with a code ref.
+{
+    my $capture = IO::c55Capture->new_handle;
+    my $harness = TAP::Harness->new(
+        {   verbosity => -2,
+            stdout    => $capture,
+            exec      => sub {undef},
+        }
+    );
+
+    _runtests( $harness, "$source_tests/harness" );
+
+    my @output = tied($$capture)->dump;
+    my $status = pop @output;
+    like $status, qr{^Result: PASS$},
+      '... and the status line should be correct';
+    pop @output;    # get rid of summary line
+    my $answer = pop @output;
+    is( $answer, "All tests successful.\n", 'cat meows' );
+}
+
 # catches "exec accumulates arguments" issue (r77)
 {
     my $capture = IO::c55Capture->new_handle;
@@ -820,3 +841,49 @@ sub _runtests {
         $source_tests, 'harness'
     );
 }
+
+{
+
+    # test name munging
+    my @cases = (
+        {   name   => 'all the same',
+            input  => [ 'foo.t', 'bar.t', 'fletz.t' ],
+            output => [
+                [ 'foo.t', 'foo' ], [ 'bar.t', 'bar' ], [ 'fletz.t', 'fletz' ]
+            ],
+        },
+        {   name   => 'all the same, already cooked',
+            input  => [ 'foo.t', [ 'bar.t', 'brip' ], 'fletz.t' ],
+            output => [
+                [ 'foo.t', 'foo' ], [ 'bar.t', 'brip' ],
+                [ 'fletz.t', 'fletz' ]
+            ],
+        },
+        {   name   => 'different exts',
+            input  => [ 'foo.t', 'bar.u', 'fletz.v' ],
+            output => [
+                [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bar.u' ],
+                [ 'fletz.v', 'fletz.v' ]
+            ],
+        },
+        {   name   => 'different exts, one already cooked',
+            input  => [ 'foo.t', [ 'bar.u', 'bam' ], 'fletz.v' ],
+            output => [
+                [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam' ],
+                [ 'fletz.v', 'fletz.v' ]
+            ],
+        },
+        {   name   => 'different exts, two already cooked',
+            input  => [ 'foo.t', [ 'bar.u', 'bam.q' ], [ 'fletz.v', 'boo' ] ],
+            output => [
+                [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam.q' ],
+                [ 'fletz.v', 'boo' ]
+            ],
+        },
+    );
+
+    for my $case (@cases) {
+        is_deeply [ TAP::Harness->_add_descriptions( @{ $case->{input} } ) ],
+          $case->{output}, '_add_descriptions: ' . $case->{name};
+    }
+}
index 44d2004..11b2899 100644 (file)
@@ -7,7 +7,7 @@ use Test::More tests => 76;
 
 use File::Spec;
 use TAP::Parser;
-use TAP::Parser::Iterator;
+use TAP::Parser::IteratorFactory;
 use Config;
 
 sub array_ref_from {
@@ -41,8 +41,10 @@ my @schedule = (
         source   => {
             command => [
                 $^X,
-                File::Spec->catfile( ($ENV{PERL_CORE} ? 'lib' : 't'),
-                                    'sample-tests', 'out_err_mix' )
+                File::Spec->catfile(
+                    ( $ENV{PERL_CORE} ? 'lib' : 't' ),
+                    'sample-tests', 'out_err_mix'
+                )
             ],
             merge    => 1,
             setup    => $setup,
@@ -79,6 +81,7 @@ sub _can_open3 {
     return $^O eq 'MSWin32' || $Config{d_fork};
 }
 
+my $factory = TAP::Parser::IteratorFactory->new;
 for my $test (@schedule) {
     SKIP: {
         my $name       = $test->{name};
@@ -86,9 +89,12 @@ for my $test (@schedule) {
         skip "No open3", $need_open3 if $need_open3 && !_can_open3();
         my $subclass = $test->{subclass};
         my $source   = $test->{source};
-        my $class    = $test->{class} || 'TAP::Parser::Iterator';
-        ok my $iter = $class->new($source),
-          "$name: We should be able to create a new iterator";
+        my $class    = $test->{class};
+        my $iter
+          = $class
+          ? $class->new($source)
+          : $factory->make_iterator($source);
+        ok $iter,     "$name: We should be able to create a new iterator";
         isa_ok $iter, 'TAP::Parser::Iterator',
           '... and the object it returns';
         isa_ok $iter, $subclass, '... and the object it returns';
@@ -126,7 +132,7 @@ for my $test (@schedule) {
 
     # coverage tests for the ctor
 
-    my $stream = TAP::Parser::Iterator->new( IO::Handle->new );
+    my $stream = $factory->make_iterator( IO::Handle->new );
 
     isa_ok $stream, 'TAP::Parser::Iterator::Stream';
 
@@ -135,7 +141,7 @@ for my $test (@schedule) {
     eval {
         local $SIG{__DIE__} = sub { push @die, @_ };
 
-        TAP::Parser::Iterator->new( \1 );    # a ref to a scalar
+        $factory->make_iterator( \1 );    # a ref to a scalar
     };
 
     is @die, 1, 'coverage of error case';
@@ -148,7 +154,7 @@ for my $test (@schedule) {
 
     # coverage test for VMS case
 
-    my $stream = TAP::Parser::Iterator->new(
+    my $stream = $factory->make_iterator(
         [   'not ',
             'ok 1 - I hate VMS',
         ]
@@ -159,7 +165,7 @@ for my $test (@schedule) {
 
     # coverage test for VMS case - nothing after 'not'
 
-    $stream = TAP::Parser::Iterator->new(
+    $stream = $factory->make_iterator(
         [   'not ',
         ]
     );
@@ -177,7 +183,7 @@ SKIP: {
     eval {
         local $SIG{__DIE__} = sub { push @die, @_ };
 
-        TAP::Parser::Iterator->new( {} );
+        $factory->make_iterator( {} );
     };
 
     is @die, 1, 'coverage testing for TPI::Process';
@@ -185,7 +191,7 @@ SKIP: {
     like pop @die, qr/Must supply a command to execute/,
       '...and we died as expected';
 
-    my $parser = TAP::Parser::Iterator->new(
+    my $parser = $factory->make_iterator(
         {   command => [
                 $^X,
                 File::Spec->catfile( 't', 'sample-tests', 'out_err_mix' )
@@ -194,7 +200,7 @@ SKIP: {
         }
     );
 
-    is $parser->{err}, '', 'confirm we set err to empty string';
+    is $parser->{err}, '',    'confirm we set err to empty string';
     is $parser->{sel}, undef, '...and selector to undef';
 
     # And then we read from the parser to sidestep the Mac OS / open3
index e74c15c..dd988dc 100644 (file)
@@ -56,8 +56,8 @@ my @schedule = (
             return [
                 TAP::Parser->new(
                     {   source => File::Spec->catfile(
-                            ($ENV{PERL_CORE} ? 'lib' : 't'), 'sample-tests',
-                           'simple'
+                            ( $ENV{PERL_CORE} ? 'lib' : 't' ), 'sample-tests',
+                            'simple'
                         ),
                     }
                 ),
@@ -76,8 +76,8 @@ my @schedule = (
             return map {
                 [   TAP::Parser->new(
                         {   source => File::Spec->catfile(
-                                ($ENV{PERL_CORE} ? 'lib' : 't'),
-                               'sample-tests', 'simple'
+                                ( $ENV{PERL_CORE} ? 'lib' : 't' ),
+                                'sample-tests', 'simple'
                             ),
                         }
                     ),
@@ -116,8 +116,8 @@ my @schedule = (
               ( map {
                     [   TAP::Parser->new(
                             {   source => File::Spec->catfile(
-                                    ($ENV{PERL_CORE} ? 'lib' : 't'),
-                                   'sample-tests', 'simple'
+                                    ( $ENV{PERL_CORE} ? 'lib' : 't' ),
+                                    'sample-tests', 'simple'
                                 ),
                             }
                         ),
diff --git a/lib/Test/Harness/t/object.t b/lib/Test/Harness/t/object.t
new file mode 100644 (file)
index 0000000..b1a4dd0
--- /dev/null
@@ -0,0 +1,37 @@
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 7;
+
+use_ok('TAP::Object');
+
+can_ok( 'TAP::Object', 'new' );
+can_ok( 'TAP::Object', '_initialize' );
+can_ok( 'TAP::Object', '_croak' );
+
+{
+
+    package TAP::TestObj;
+    use vars qw(@ISA);
+    @ISA = qw(TAP::Object);
+
+    sub _initialize {
+        my $self = shift;
+        $self->{init} = 1;
+        $self->{args} = [@_];
+        return $self;
+    }
+}
+
+# I know these tests are simple, but they're documenting the base API, so
+# necessary none-the-less...
+my $obj = TAP::TestObj->new( 'foo', { bar => 'baz' } );
+ok( $obj->{init}, '_initialize' );
+is_deeply( $obj->{args}, [ 'foo', { bar => 'baz' } ], '_initialize: args' );
+
+eval { $obj->_croak('eek') };
+my $err = $@;
+like( $err, qr/^eek/, '_croak' );
+
index a53ad3a..7118199 100755 (executable)
@@ -12,13 +12,13 @@ BEGIN {
     }
 }
 
-use Test::More tests => 268;
+use Test::More tests => 282;
 use IO::c55Capture;
 
 use File::Spec;
 
 use TAP::Parser;
-use TAP::Parser::Iterator;
+use TAP::Parser::IteratorFactory;
 
 sub _get_results {
     my $parser = shift;
@@ -41,6 +41,8 @@ my ( $PARSER, $PLAN, $PRAGMA, $TEST, $COMMENT, $BAILOUT, $UNKNOWN, $YAML, $VERSI
   TAP::Parser::Result::Version
 );
 
+my $factory = TAP::Parser::IteratorFactory->new;
+
 my $tap = <<'END_TAP';
 TAP version 13
 1..7
@@ -220,7 +222,7 @@ ok $test->is_actual_ok,
   '... and the correct boolean version of is_actual_ok()';
 is $test->number, 5, '... and have the correct test number';
 ok !$test->description, '... and skipped tests have no description';
-is $test->directive, 'SKIP', '... and teh correct directive';
+is $test->directive, 'SKIP', '... and the correct directive';
 is $test->explanation, 'we have no description',
   '... but we should have an explanation';
 ok $test->has_skip, '... and it is a SKIPped test';
@@ -349,7 +351,7 @@ END_TAP
 my $aref = [ split /\n/ => $tap ];
 
 can_ok $PARSER, 'new';
-$parser = $PARSER->new( { stream => TAP::Parser::Iterator->new($aref) } );
+$parser = $PARSER->new( { stream => $factory->make_iterator($aref) } );
 isa_ok $parser, $PARSER, '... and calling it should succeed';
 
 # results() is sane?
@@ -436,29 +438,6 @@ is $test->raw, 'ok 2 - read the rest of the file',
 is scalar $parser->passed, 2,
   'Empty junk lines should not affect the correct number of tests passed';
 
-# coverage tests
-{
-
-    # calling a TAP::Parser internal method with a 'foreign' class
-
-    my $foreigner = bless {}, 'Foreigner';
-
-    my @die;
-
-    eval {
-        local $SIG{__DIE__} = sub { push @die, @_ };
-
-        TAP::Parser::_stream $foreigner, qw(a b c);
-    };
-
-    unless ( is @die, 1, 'coverage testing for TAP::Parser accessors' ) {
-        diag " >>> $_ <<<\n" for @die;
-    }
-
-    like pop @die, qr/_stream[(][)] may not be set externally/,
-      '... and we died with expected message';
-}
-
 {
 
     # set a spool to write to
@@ -662,10 +641,10 @@ END_TAP
 
     _get_results($parser);
 
-    ok !$parser->failed;
-    ok $parser->todo_passed;
+    ok !$parser->failed, 'parser didnt fail';
+    ok $parser->todo_passed, '... and todo_passed is true';
 
-    ok !$parser->has_problems, 'and has_problems is false';
+    ok !$parser->has_problems, '... and has_problems is false';
 
     # now parse_errors
 
@@ -679,11 +658,11 @@ END_TAP
 
     _get_results($parser);
 
-    ok !$parser->failed;
-    ok !$parser->todo_passed;
-    ok $parser->parse_errors;
+    ok !$parser->failed,      'parser didnt fail';
+    ok !$parser->todo_passed, '... and todo_passed is false';
+    ok $parser->parse_errors, '... and parse_errors is true';
 
-    ok $parser->has_problems;
+    ok $parser->has_problems, '... and has_problems';
 
     # Now wait and exit are hard to do in an OS platform-independent way, so
     # we won't even bother
@@ -701,27 +680,27 @@ END_TAP
 
     $parser->wait(1);
 
-    ok !$parser->failed;
-    ok !$parser->todo_passed;
-    ok !$parser->parse_errors;
+    ok !$parser->failed,       'parser didnt fail';
+    ok !$parser->todo_passed,  '... and todo_passed is false';
+    ok !$parser->parse_errors, '... and parse_errors is false';
 
-    ok $parser->wait;
+    ok $parser->wait, '... and wait is set';
 
-    ok $parser->has_problems;
+    ok $parser->has_problems, '... and has_problems';
 
     # and use the same for exit
 
     $parser->wait(0);
     $parser->exit(1);
 
-    ok !$parser->failed;
-    ok !$parser->todo_passed;
-    ok !$parser->parse_errors;
-    ok !$parser->wait;
+    ok !$parser->failed,       'parser didnt fail';
+    ok !$parser->todo_passed,  '... and todo_passed is false';
+    ok !$parser->parse_errors, '... and parse_errors is false';
+    ok !$parser->wait,         '... and wait is not set';
 
-    ok $parser->exit;
+    ok $parser->exit, '... and exit is set';
 
-    ok $parser->has_problems;
+    ok $parser->has_problems, '... and has_problems';
 }
 
 {
@@ -807,10 +786,6 @@ END_TAP
 
     @ISA = qw(TAP::Parser::Iterator);
 
-    sub new {
-        return bless {}, shift;
-    }
-
     sub next_raw {
         die 'this is the dying iterator';
     }
@@ -840,7 +815,11 @@ END_TAP
         $parser->_stream($stream);
 
         # build a new grammar
-        my $grammar = TAP::Parser::Grammar->new($stream);
+        my $grammar = TAP::Parser::Grammar->new(
+            {   stream => $stream,
+                parser => $parser
+            }
+        );
 
         # replace our grammar with this new one
         $parser->_grammar($grammar);
@@ -872,7 +851,11 @@ END_TAP
         $parser->_stream($stream);
 
         # build a new grammar
-        my $grammar = TAP::Parser::Grammar->new($stream);
+        my $grammar = TAP::Parser::Grammar->new(
+            {   stream => $stream,
+                parser => $parser
+            }
+        );
 
         # replace our grammar with this new one
         $parser->_grammar($grammar);
@@ -1018,3 +1001,40 @@ END_TAP
 
     is_deeply [ sort keys %reachable ], [@states], "all states reachable";
 }
+
+{
+
+    # exit, wait, ignore_exit interactions
+
+    my @truth = (
+        [ 0, 0, 0, 0 ],
+        [ 0, 0, 1, 0 ],
+        [ 1, 0, 0, 1 ],
+        [ 1, 0, 1, 0 ],
+        [ 1, 1, 0, 1 ],
+        [ 1, 1, 1, 0 ],
+        [ 0, 1, 0, 1 ],
+        [ 0, 1, 1, 0 ],
+    );
+
+    for my $t (@truth) {
+        my ( $wait, $exit, $ignore_exit, $has_problems ) = @$t;
+        my $test_parser = sub {
+            my $parser = shift;
+            $parser->wait($wait);
+            $parser->exit($exit);
+            ok $has_problems ? $parser->has_problems : !$parser->has_problems,
+              "exit=$exit, wait=$wait, ignore=$ignore_exit";
+        };
+
+        my $parser = TAP::Parser->new( { tap => "1..1\nok 1\n" } );
+        $parser->ignore_exit($ignore_exit);
+        $test_parser->($parser);
+
+        $test_parser->(
+            TAP::Parser->new(
+                { tap => "1..1\nok 1\n", ignore_exit => $ignore_exit }
+            )
+        );
+    }
+}
diff --git a/lib/Test/Harness/t/parser-config.t b/lib/Test/Harness/t/parser-config.t
new file mode 100644 (file)
index 0000000..cf0a246
--- /dev/null
@@ -0,0 +1,46 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+    if ( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ( '../lib', 'lib' );
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use strict;
+use vars qw(%INIT %CUSTOM);
+
+use Test::More tests => 11;
+use File::Spec::Functions qw( catfile );
+use TAP::Parser;
+
+use_ok('MySource');
+use_ok('MyPerlSource');
+use_ok('MyGrammar');
+use_ok('MyIteratorFactory');
+use_ok('MyResultFactory');
+
+my $t_dir = $ENV{PERL_CORE} ? 'lib' : 't';
+my $source = catfile( $t_dir, 'source_tests', 'source' );
+my %customize = (
+    source_class           => 'MySource',
+    perl_source_class      => 'MyPerlSource',
+    grammar_class          => 'MyGrammar',
+    iterator_factory_class => 'MyIteratorFactory',
+    result_factory_class   => 'MyResultFactory',
+);
+my $p = TAP::Parser->new(
+    {   source => $source,
+        %customize,
+    }
+);
+ok( $p, 'new customized parser' );
+
+foreach my $key ( keys %customize ) {
+    is( $p->$key(), $customize{$key}, "customized $key" );
+}
+
+# TODO: make sure these things are propogated down through the parser...
diff --git a/lib/Test/Harness/t/parser-subclass.t b/lib/Test/Harness/t/parser-subclass.t
new file mode 100644 (file)
index 0000000..f522f89
--- /dev/null
@@ -0,0 +1,88 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+    if ( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ( '../lib', 'lib' );
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use strict;
+use vars qw(%INIT %CUSTOM);
+
+use Test::More tests => 24;
+use File::Spec::Functions qw( catfile );
+
+use_ok('TAP::Parser::SubclassTest');
+
+# TODO: foreach my $source ( ... )
+my $t_dir = $ENV{PERL_CORE} ? 'lib' : 't';
+
+{    # perl source
+    %INIT = %CUSTOM = ();
+    my $source = catfile( $t_dir, 'subclass_tests', 'perl_source' );
+    my $p = TAP::Parser::SubclassTest->new( { source => $source } );
+
+    # The grammar is lazily constructed so we need to ask for it to
+    # trigger it's creation.
+    my $grammer = $p->_grammar;
+
+    ok( $p->{initialized}, 'new subclassed parser' );
+
+    is( $p->source_class      => 'MySource',     'source_class' );
+    is( $p->perl_source_class => 'MyPerlSource', 'perl_source_class' );
+    is( $p->grammar_class     => 'MyGrammar',    'grammar_class' );
+    is( $p->iterator_factory_class => 'MyIteratorFactory',
+        'iterator_factory_class'
+    );
+    is( $p->result_factory_class => 'MyResultFactory',
+        'result_factory_class'
+    );
+
+    is( $INIT{MyPerlSource},   1, 'initialized MyPerlSource' );
+    is( $CUSTOM{MyPerlSource}, 1, '... and it was customized' );
+    is( $INIT{MyGrammar},      1, 'initialized MyGrammar' );
+    is( $CUSTOM{MyGrammar},    1, '... and it was customized' );
+
+    # make sure overrided make_* methods work...
+    %CUSTOM = ();
+    $p->make_source;
+    is( $CUSTOM{MySource}, 1, 'make custom source' );
+    $p->make_perl_source;
+    is( $CUSTOM{MyPerlSource}, 1, 'make custom perl source' );
+    $p->make_grammar;
+    is( $CUSTOM{MyGrammar}, 1, 'make custom grammar' );
+    $p->make_iterator;
+    is( $CUSTOM{MyIterator}, 1, 'make custom iterator' );
+    $p->make_result;
+    is( $CUSTOM{MyResult}, 1, 'make custom result' );
+
+    # make sure parser helpers use overrided classes too (the parser should
+    # be the central source of configuration/overriding functionality)
+    # The source is already tested above (parser doesn't keep a copy of the
+    # source currently).  So only one to check is the Grammar:
+    %INIT = %CUSTOM = ();
+    my $r = $p->_grammar->tokenize;
+    isa_ok( $r, 'MyResult', 'i has results' );
+    is( $INIT{MyResult},        1, 'initialized MyResult' );
+    is( $CUSTOM{MyResult},      1, '... and it was customized' );
+    is( $INIT{MyResultFactory}, 1, '"initialized" MyResultFactory' );
+}
+
+SKIP: {    # non-perl source
+    %INIT = %CUSTOM = ();
+    my $cat = '/bin/cat';
+    unless ( -e $cat ) {
+        skip "no '$cat'", 4;
+    }
+    my $file = catfile( $t_dir, 'data', 'catme.1' );
+    my $p = TAP::Parser::SubclassTest->new( { exec => [ $cat => $file ] } );
+
+    is( $INIT{MySource},     1, 'initialized MySource subclass' );
+    is( $CUSTOM{MySource},   1, '... and it was customized' );
+    is( $INIT{MyIterator},   1, 'initialized MyIterator subclass' );
+    is( $CUSTOM{MyIterator}, 1, '... and it was customized' );
+}
index d38e6d1..9226a44 100644 (file)
@@ -6,7 +6,7 @@ use lib 't/lib';
 use Test::More tests => 14;
 
 use TAP::Parser;
-use TAP::Parser::Iterator;
+use TAP::Parser::IteratorFactory;
 
 sub tap_to_lines {
     my $string = shift;
@@ -26,8 +26,9 @@ Bail out!  We ran out of foobar.
 not ok 5
 END_TAP
 
-my $parser = TAP::Parser->new(
-    {   stream => TAP::Parser::Iterator->new( tap_to_lines($tap) ),
+my $factory = TAP::Parser::IteratorFactory->new;
+my $parser  = TAP::Parser->new(
+    {   stream => $factory->make_iterator( tap_to_lines($tap) ),
     }
 );
 
@@ -105,7 +106,7 @@ is( $bailout->explanation, 'We ran out of foobar.',
 my $more_tap = "1..1\nok 1 - input file opened\n";
 
 my $second_parser = TAP::Parser->new(
-    {   stream => TAP::Parser::Iterator->new( [ split( /\n/, $more_tap ) ] ),
+    {   stream => $factory->make_iterator( [ split( /\n/, $more_tap ) ] ),
     }
 );
 
index e4d585e..5adddc9 100644 (file)
@@ -9,9 +9,11 @@ BEGIN {
     $hires = eval 'use Time::HiRes qw(sleep); 1';
 }
 
-use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' )
-    : $hires ? ( tests    => 9 * 3 )
-    :          ( skip_all => 'Need Time::HiRes' ) );
+use Test::More (
+      $^O eq 'VMS' ? ( skip_all => 'VMS' )
+    : $hires ? ( tests => 9 * 3 )
+    : ( skip_all => 'Need Time::HiRes' )
+);
 
 use File::Spec;
 use TAP::Parser::Iterator::Process;
@@ -25,8 +27,10 @@ my @expect = (
     'ok 5 00000',
 );
 
-my $source = File::Spec->catfile( ($ENV{PERL_CORE} ? 'lib' : 't'),
-                                 'sample-tests', 'delayed' );
+my $source = File::Spec->catfile(
+    ( $ENV{PERL_CORE} ? 'lib' : 't' ),
+    'sample-tests', 'delayed'
+);
 
 for my $chunk_size ( 1, 4, 65536 ) {
     for my $where ( 0 .. 8 ) {
index 02d2e31..38b9b85 100644 (file)
@@ -75,9 +75,10 @@ BEGIN {    # START PLAN
 
     # list of attributes
     @ATTR = qw(
-      archive argv blib color directives exec failures formatter harness
-      includes lib merge parse quiet really_quiet recurse backwards
-      shuffle taint_fail taint_warn verbose warnings_fail warnings_warn
+      archive argv blib color directives exec extension failures
+      formatter harness includes lib merge parse quiet really_quiet
+      recurse backwards shuffle taint_fail taint_warn verbose
+      warnings_fail warnings_warn
     );
 
     # what we expect if the 'expect' hash does not define it
diff --git a/lib/Test/Harness/t/proveenv.t b/lib/Test/Harness/t/proveenv.t
new file mode 100644 (file)
index 0000000..be9942a
--- /dev/null
@@ -0,0 +1,17 @@
+#!perl
+use strict;
+use lib 't/lib';
+use Test::More tests => 2;
+use App::Prove;
+
+{
+    local $ENV{HARNESS_TIMER} = 0;
+    my $prv = App::Prove->new;
+    ok !$prv->timer, 'timer set via HARNESS_TIMER';
+}
+
+{
+    local $ENV{HARNESS_TIMER} = 1;
+    my $prv = App::Prove->new;
+    ok $prv->timer, 'timer set via HARNESS_TIMER';
+}
index 6cda6c4..b40d563 100644 (file)
@@ -44,7 +44,7 @@ BEGIN {
         },
     );
 
-    plan tests => @SCHEDULE * 2;
+    plan tests => @SCHEDULE * 3;
 }
 
 # Waaaaay too much boilerplate
@@ -61,12 +61,6 @@ sub new {
     return $self;
 }
 
-sub _exit {
-    my $self = shift;
-    push @{ $self->{_log} }, [ '_exit', @_ ];
-    die "Exited";
-}
-
 sub get_log {
     my $self = shift;
     my @log  = @{ $self->{_log} };
@@ -85,14 +79,17 @@ package main;
 
     local $^W;    # no warnings
 
-    my $orig_new = \&TAP::Parser::Iterator::Process::new;
-    *TAP::Parser::Iterator::Process::new = sub {
+    my $orig_new = TAP::Parser::Iterator::Process->can('new');
+
+    # Avoid "used only once" warning
+    *TAP::Parser::Iterator::Process::new
+      = *TAP::Parser::Iterator::Process::new = sub {
         push @call_log, [ 'new', @_ ];
 
         # And then new turns round and tramples on our args...
         $_[1] = { %{ $_[1] } };
         $orig_new->(@_);
-    };
+      };
 
     # Patch TAP::Formatter::Console;
     my $orig_output = \&TAP::Formatter::Console::_output;
@@ -143,8 +140,8 @@ for my $test (@SCHEDULE) {
 
     # Why does this make the output from the test spew out of
     # our STDOUT?
-    eval { $app->run };
-    like $@, qr{Exited}, "$name: exited via _exit()";
+    ok eval { $app->run }, 'run returned true';
+    ok !$@, 'no errors';
 
     my @log = get_log();
 
index 5398580..c029a05 100644 (file)
@@ -2198,7 +2198,7 @@ my %samples = (
                 passed        => TRUE,
                 is_ok         => TRUE,
                 directive     => 'SKIP',
-                explanation   => 'rope'
+                explanation   => ''
             },
         ],
         plan          => '1..0',
@@ -2217,7 +2217,7 @@ my %samples = (
         'exit'        => 0,
         wait          => 0,
         version       => 12,
-        skip_all      => 'rope',
+        skip_all      => '(no reason given)',
     },
     skipall_v13 => {
         results => [
index 431bb7d..0522dd6 100644 (file)
@@ -3,8 +3,9 @@
 use strict;
 use lib 't/lib';
 
-use Test::More tests => 222;
+use Test::More tests => 227;
 
+use TAP::Parser::ResultFactory;
 use TAP::Parser::Result;
 
 use constant RESULT  => 'TAP::Parser::Result';
@@ -22,6 +23,7 @@ $SIG{__WARN__} = sub { $warning = shift };
 # found in the regression tests.
 #
 
+my $factory           = TAP::Parser::ResultFactory->new;
 my %inherited_methods = (
     is_plan    => '',
     is_test    => '',
@@ -46,11 +48,32 @@ like $warning, qr/^\Qpassed() is deprecated.  Please use "is_ok()"/,
   '... but it should emit a deprecation warning';
 
 can_ok RESULT, 'new';
-eval { RESULT->new( { type => 'no_such_type' } ) };
+
+can_ok $factory, 'make_result';
+eval { $factory->make_result( { type => 'no_such_type' } ) };
 ok my $error = $@, '... and calling it with an unknown class should fail';
 like $error, qr/^Could not determine class for.*no_such_type/s,
   '... with an appropriate error message';
 
+# register new Result types:
+can_ok $factory, 'class_for';
+can_ok $factory, 'register_type';
+{
+
+    package MyResult;
+    use strict;
+    use vars qw($VERSION @ISA);
+    @ISA = 'TAP::Parser::Result';
+    TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
+}
+
+{
+    my $r = eval { $factory->make_result( { type => 'my_type' } ) };
+    my $error = $@;
+    isa_ok( $r, 'MyResult', 'register custom type' );
+    ok( !$error, '... and no error' );
+}
+
 #
 # test unknown tokens
 #
@@ -246,7 +269,7 @@ sub run_tests {
 sub instantiate {
     my $instantiated = shift;
     my $class        = $instantiated->{class};
-    ok my $result = RESULT->new( $instantiated->{data} ),
+    ok my $result = $factory->make_result( $instantiated->{data} ),
       'Creating $class results should succeed';
     isa_ok $result, $class, '.. and the object it returns';
     return $result;
diff --git a/lib/Test/Harness/t/scheduler.t b/lib/Test/Harness/t/scheduler.t
new file mode 100644 (file)
index 0000000..b274207
--- /dev/null
@@ -0,0 +1,225 @@
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More;
+use TAP::Parser::Scheduler;
+
+my $perl_rules = {
+    par => [
+        { seq => '../ext/DB_File/t/*' },
+        { seq => '../ext/IO_Compress_Zlib/t/*' },
+        { seq => '../lib/CPANPLUS/*' },
+        { seq => '../lib/ExtUtils/t/*' },
+        '*'
+    ]
+};
+
+my $incomplete_rules = { par => [ { seq => [ '*A', '*D' ] } ] };
+
+my $some_tests = [
+    '../ext/DB_File/t/A',
+    'foo',
+    '../ext/DB_File/t/B',
+    '../ext/DB_File/t/C',
+    '../lib/CPANPLUS/D',
+    '../lib/CPANPLUS/E',
+    'bar',
+    '../lib/CPANPLUS/F',
+    '../ext/DB_File/t/D',
+    '../ext/DB_File/t/E',
+    '../ext/DB_File/t/F',
+];
+
+my @schedule = (
+    {   name  => 'Sequential, no rules',
+        tests => $some_tests,
+        jobs  => 1,
+    },
+    {   name  => 'Sequential, Perl rules',
+        rules => $perl_rules,
+        tests => $some_tests,
+        jobs  => 1,
+    },
+    {   name  => 'Two in parallel, Perl rules',
+        rules => $perl_rules,
+        tests => $some_tests,
+        jobs  => 2,
+    },
+    {   name  => 'Massively parallel, Perl rules',
+        rules => $perl_rules,
+        tests => $some_tests,
+        jobs  => 1000,
+    },
+    {   name  => 'Massively parallel, no rules',
+        tests => $some_tests,
+        jobs  => 1000,
+    },
+    {   name  => 'Sequential, incomplete rules',
+        rules => $incomplete_rules,
+        tests => $some_tests,
+        jobs  => 1,
+    },
+    {   name  => 'Two in parallel, incomplete rules',
+        rules => $incomplete_rules,
+        tests => $some_tests,
+        jobs  => 2,
+    },
+    {   name  => 'Massively parallel, incomplete rules',
+        rules => $incomplete_rules,
+        tests => $some_tests,
+        jobs  => 1000,
+    },
+);
+
+plan tests => @schedule * 2 + 266;
+
+for my $test (@schedule) {
+    test_scheduler(
+        $test->{name},
+        $test->{tests},
+        $test->{rules},
+        $test->{jobs}
+    );
+}
+
+# An ad-hoc test
+
+{
+    my @tests = qw(
+      A1 A2 A3 B1 C1 C8 C5 C7 C4 C6 C3 C2 C9 D1 D2 D3 E3 E2 E1
+    );
+
+    my $rules = {
+        par => [
+            { seq => 'A*' },
+            { par => 'B*' },
+            { seq => [ 'C1', 'C2' ] },
+            {   par => [
+                    { seq => [ 'C3', 'C4', 'C5' ] },
+                    { seq => [ 'C6', 'C7', 'C8' ] }
+                ]
+            },
+            {   seq => [
+                    { par => ['D*'] },
+                    { par => ['E*'] }
+                ]
+            },
+        ]
+    };
+
+    my $scheduler = TAP::Parser::Scheduler->new(
+        tests => \@tests,
+        rules => $rules
+    );
+
+    # diag $scheduler->as_string;
+
+    my $A1 = ok_job( $scheduler, 'A1' );
+    my $B1 = ok_job( $scheduler, 'B1' );
+    finish($A1);
+    my $A2 = ok_job( $scheduler, 'A2' );
+    my $C1 = ok_job( $scheduler, 'C1' );
+    finish( $A2, $C1 );
+    my $A3 = ok_job( $scheduler, 'A3' );
+    my $C2 = ok_job( $scheduler, 'C2' );
+    finish( $A3, $C2 );
+    my $C3 = ok_job( $scheduler, 'C3' );
+    my $C6 = ok_job( $scheduler, 'C6' );
+    my $D1 = ok_job( $scheduler, 'D1' );
+    my $D2 = ok_job( $scheduler, 'D2' );
+    finish($C6);
+    my $C7 = ok_job( $scheduler, 'C7' );
+    my $D3 = ok_job( $scheduler, 'D3' );
+    ok_job( $scheduler, '#' );
+    ok_job( $scheduler, '#' );
+    finish( $D3, $C3, $D1, $B1 );
+    my $C4 = ok_job( $scheduler, 'C4' );
+    finish( $C4, $C7 );
+    my $C5 = ok_job( $scheduler, 'C5' );
+    my $C8 = ok_job( $scheduler, 'C8' );
+    ok_job( $scheduler, '#' );
+    finish($D2);
+    my $E3 = ok_job( $scheduler, 'E3' );
+    my $E2 = ok_job( $scheduler, 'E2' );
+    my $E1 = ok_job( $scheduler, 'E1' );
+    finish( $E1, $E2, $E3, $C5, $C8 );
+    my $C9 = ok_job( $scheduler, 'C9' );
+    ok_job( $scheduler, undef );
+}
+
+{
+    my @tests = ();
+    for my $t ( 'A' .. 'Z' ) {
+        push @tests, map {"$t$_"} 1 .. 9;
+    }
+    my $rules = { par => [ map { { seq => "$_*" } } 'A' .. 'Z' ] };
+
+    my $scheduler = TAP::Parser::Scheduler->new(
+        tests => \@tests,
+        rules => $rules
+    );
+
+    # diag $scheduler->as_string;
+
+    for my $n ( 1 .. 9 ) {
+        my @got = ();
+        push @got, ok_job( $scheduler, "$_$n" ) for 'A' .. 'Z';
+        ok_job( $scheduler, $n == 9 ? undef : '#' );
+        finish(@got);
+    }
+}
+
+sub finish { $_->finish for @_ }
+
+sub ok_job {
+    my ( $scheduler, $want ) = @_;
+    my $job = $scheduler->get_job;
+    if ( !defined $want ) {
+        ok !defined $job, 'undef';
+    }
+    elsif ( $want eq '#' ) {
+        ok $job->is_spinner, 'spinner';
+    }
+    else {
+        is $job->filename, $want, $want;
+    }
+    return $job;
+}
+
+sub test_scheduler {
+    my ( $name, $tests, $rules, $jobs ) = @_;
+
+    ok my $scheduler = TAP::Parser::Scheduler->new(
+        tests => $tests,
+        defined $rules ? ( rules => $rules ) : (),
+      ),
+      "$name: new";
+
+    # diag $scheduler->as_string;
+
+    my @pipeline = ();
+    my @got      = ();
+
+    while ( defined( my $job = $scheduler->get_job ) ) {
+
+        # diag $scheduler->as_string;
+        if ( $job->is_spinner || @pipeline >= $jobs ) {
+            die "Oops! Spinner!" unless @pipeline;
+            my $done = shift @pipeline;
+            $done->finish;
+
+            # diag "Completed ", $done->filename;
+        }
+        next if $job->is_spinner;
+
+        # diag "      Got ", $job->filename;
+        push @pipeline, $job;
+
+        push @got, $job->filename;
+    }
+
+    is_deeply [ sort @got ], [ sort @$tests ], "$name: got all tests";
+}
+
index cfdf751..8f7e60f 100644 (file)
@@ -12,14 +12,16 @@ BEGIN {
 
 use strict;
 
-use Test::More tests => 30;
+use Test::More tests => 26;
 
 use File::Spec;
 
+use EmptyParser;
 use TAP::Parser::Source;
 use TAP::Parser::Source::Perl;
 
-my $test = File::Spec->catfile(
+my $parser = EmptyParser->new;
+my $test   = File::Spec->catfile(
     ( $ENV{PERL_CORE} ? 'lib' : 't' ), 'source_tests',
     'source'
 );
@@ -39,7 +41,7 @@ ok $source->source( [ $perl, '-It/lib', '-T', $test ] ),
   '... and calling it with valid args should succeed';
 
 can_ok $source, 'get_stream';
-my $stream = $source->get_stream;
+my $stream = $source->get_stream($parser);
 
 isa_ok $stream, 'TAP::Parser::Iterator::Process',
   'get_stream returns the right object';
@@ -57,7 +59,7 @@ ok $source->source( [$test] ),
   '... and calling it with valid args should succeed';
 
 can_ok $source, 'get_stream';
-$stream = $source->get_stream;
+$stream = $source->get_stream($parser);
 
 isa_ok $stream, 'TAP::Parser::Iterator::Process',
   '... and the object it returns';
@@ -79,7 +81,7 @@ ok( grep( $_ =~ /^['"]?-T['"]?$/, $source->_switches ),
 
     # coverage for method get_steam
 
-    my $source = TAP::Parser::Source->new();
+    my $source = TAP::Parser::Source->new( { parser => $parser } );
 
     my @die;
 
@@ -94,36 +96,3 @@ ok( grep( $_ =~ /^['"]?-T['"]?$/, $source->_switches ),
     like pop @die, qr/No command found!/, '...and it failed as expect';
 }
 
-{
-
-    # coverage testing for error
-
-    my $source = TAP::Parser::Source->new();
-
-    my $error = $source->error;
-
-    is $error, undef, 'coverage testing for error()';
-
-    $source->error('save me');
-
-    $error = $source->error;
-
-    is $error, 'save me', '...and we got the expected message';
-}
-
-{
-
-    # coverage testing for exit
-
-    my $source = TAP::Parser::Source->new();
-
-    my $exit = $source->exit;
-
-    is $exit, undef, 'coverage testing for exit()';
-
-    $source->exit('save me');
-
-    $exit = $source->exit;
-
-    is $exit, 'save me', '...and we got the expected message';
-}
index 428423a..deb1a02 100644 (file)
@@ -117,8 +117,9 @@ ok 1 - input file opened
 END_TAP
 
     my $parser = TAP::Parser->new(
-        {   spool  => $spoolHandle,
-            stream => TAP::Parser::Iterator->new( [ split /\n/ => $tap ] )
+        {   spool => $spoolHandle,
+            stream =>
+              TAP::Parser::IteratorFactory->new( [ split /\n/ => $tap ] )
         }
     );
 
index fba0591..b312ae8 100755 (executable)
@@ -6,13 +6,15 @@ use lib 't/lib';
 use Test::More tests => 47;
 
 use TAP::Parser;
-use TAP::Parser::Iterator;
+use TAP::Parser::IteratorFactory;
 
-my ( $STREAMED, $ITER ) = ( 'TAP::Parser', 'TAP::Parser::Iterator' );
+my $STREAMED   = 'TAP::Parser';
+my $ITER       = 'TAP::Parser::Iterator';
 my $ITER_FH    = "${ITER}::Stream";
 my $ITER_ARRAY = "${ITER}::Array";
 
-my $stream = TAP::Parser::Iterator->new( \*DATA );
+my $factory = TAP::Parser::IteratorFactory->new;
+my $stream  = $factory->make_iterator( \*DATA );
 isa_ok $stream, 'TAP::Parser::Iterator';
 my $parser = TAP::Parser->new( { stream => $stream } );
 isa_ok $parser, 'TAP::Parser',
@@ -55,7 +57,7 @@ ok 5 # skip we have no description
 1..5
 END_TAP
 
-$stream = $ITER->new( [ split /\n/ => $tap ] );
+$stream = $factory->make_iterator( [ split /\n/ => $tap ] );
 ok $parser = TAP::Parser->new( { stream => $stream } ),
   'Now we create a parser with the plan at the end';
 isa_ok $parser->_stream, $ITER_ARRAY,
@@ -93,7 +95,7 @@ not ok 4 - this is a real failure
 ok 5 # skip we have no description
 END_TAP
 
-$stream = $ITER->new( [ split /\n/ => $tap ] );
+$stream = $factory->make_iterator( [ split /\n/ => $tap ] );
 
 ok $parser = TAP::Parser->new( { stream => $stream } ),
   'Now we create a parser with a plan as the second line';
@@ -131,7 +133,7 @@ not ok 4 - this is a real failure
 ok 5 # skip we have no description
 END_TAP
 
-$stream = $ITER->new( [ split /\n/ => $tap ] );
+$stream = $factory->make_iterator( [ split /\n/ => $tap ] );
 
 ok $parser = TAP::Parser->new( { stream => $stream } ),
   'Now we create a parser with the plan as the second to last line';
index 76ee9a5..9160c59 100644 (file)
@@ -13,8 +13,10 @@ use TAP::Parser;
 use TAP::Harness;
 use App::Prove;
 
-my $test = File::Spec->catfile( ($ENV{PERL_CORE} ? 'lib' : 't'),
-                               'sample-tests', 'echo' );
+my $test = File::Spec->catfile(
+    ( $ENV{PERL_CORE} ? 'lib' : 't' ),
+    'sample-tests', 'echo'
+);
 
 diag( "\n\n", bigness( join ' ', @ARGV ), "\n\n" ) if @ARGV;
 
index de52689..88d3208 100644 (file)
@@ -9,6 +9,7 @@ my @schedule;
 my %make_test;
 
 BEGIN {
+
     # TODO: Investigate failure on 5.8.0
     plan skip_all => "unicode on Perl <= 5.8.0"
       unless $] > 5.008;
index 3cdaf54..76ba798 100644 (file)
@@ -1,4 +1,4 @@
-#!/usr/bin/perl -w
+#!perl -w
 
 use strict;
 use lib 't/lib';
@@ -48,6 +48,15 @@ BEGIN {
             ],
             out => "Hello, World\n",
         },
+        {   name => 'Hello World Block',
+            in   => [
+                '--- |',
+                '   Hello,',
+                '      World',
+                '...',
+            ],
+            out => "Hello,\n   World\n",
+        },
         {   name => 'Hello World 5',
             in   => [
                 '--- >',
@@ -128,7 +137,10 @@ BEGIN {
                 six => '6'
             },
         },
-
+        {   name => 'Space after colon',
+            in   => [ '---', 'spog: ', ' - 1', ' - 2', '...' ],
+            out => { spog => [ 1, 2 ] },
+        },
         {   name => 'Original YAML::Tiny test',
             in   => [
                 '---',
@@ -471,6 +483,10 @@ BEGIN {
                 "\n\t" => 'newline, tab',
             },
         },
+        {   name => 'Empty',
+            in   => [],
+            out  => undef,
+        },
     );
 
     plan tests => @SCHEDULE * 5;
index 55bf3a6..7e285bd 100644 (file)
@@ -1,7 +1,7 @@
 package App::Prove::Plugin::Dummy;
 
 sub import {
-    main::test_log_import( @_ );
+    main::test_log_import(@_);
 }
 
 1;
diff --git a/t/lib/EmptyParser.pm b/t/lib/EmptyParser.pm
new file mode 100644 (file)
index 0000000..2f7ec24
--- /dev/null
@@ -0,0 +1,30 @@
+package EmptyParser;
+
+use strict;
+use vars qw(@ISA);
+
+use TAP::Parser ();
+
+@ISA = qw(TAP::Parser);
+
+sub _initialize {
+    shift->_set_defaults;
+}
+
+# this should really be in TAP::Parser itself...
+sub _set_defaults {
+    my $self = shift;
+
+    for my $key (
+        qw( source_class perl_source_class grammar_class
+        iterator_factory_class result_factory_class )
+      )
+    {
+        my $default_method = "_default_$key";
+        $self->$key( $self->$default_method() );
+    }
+
+    return $self;
+}
+
+1;
diff --git a/t/lib/MyCustom.pm b/t/lib/MyCustom.pm
new file mode 100644 (file)
index 0000000..2402312
--- /dev/null
@@ -0,0 +1,12 @@
+# avoid cut-n-paste exhaustion with this mixin
+
+package MyCustom;
+use strict;
+
+sub custom {
+    my $self = shift;
+    $main::CUSTOM{ ref($self) }++;
+    return $self;
+}
+
+1;
diff --git a/t/lib/MyGrammar.pm b/t/lib/MyGrammar.pm
new file mode 100644 (file)
index 0000000..ef93f9d
--- /dev/null
@@ -0,0 +1,21 @@
+# subclass for testing customizing & subclassing
+
+package MyGrammar;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use TAP::Parser::Grammar;
+
+@ISA = qw( TAP::Parser::Grammar MyCustom );
+
+sub _initialize {
+    my $self = shift;
+    $self->SUPER::_initialize(@_);
+    $main::INIT{ ref($self) }++;
+    $self->{initialized} = 1;
+    return $self;
+}
+
+1;
diff --git a/t/lib/MyIterator.pm b/t/lib/MyIterator.pm
new file mode 100644 (file)
index 0000000..561f6e2
--- /dev/null
@@ -0,0 +1,26 @@
+# subclass for testing customizing & subclassing
+
+package MyIterator;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use TAP::Parser::Iterator;
+
+@ISA = qw( TAP::Parser::Iterator MyCustom );
+
+sub _initialize {
+    my $self = shift;
+    $self->SUPER::_initialize(@_);
+    $main::INIT{ ref($self) }++;
+    $self->{initialized} = 1;
+    $self->{content} = [ 'whats TAP all about then?', '1..1', 'ok 1' ];
+    return $self;
+}
+
+sub next {
+    return shift @{ $_[0]->{content} };
+}
+
+1;
diff --git a/t/lib/MyIteratorFactory.pm b/t/lib/MyIteratorFactory.pm
new file mode 100644 (file)
index 0000000..d8c3269
--- /dev/null
@@ -0,0 +1,19 @@
+# subclass for testing customizing & subclassing
+
+package MyIteratorFactory;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use MyIterator;
+use TAP::Parser::IteratorFactory;
+
+@ISA = qw( TAP::Parser::IteratorFactory MyCustom );
+
+sub make_iterator {
+    my $class = shift;
+    return MyIterator->new(@_);
+}
+
+1;
diff --git a/t/lib/MyPerlSource.pm b/t/lib/MyPerlSource.pm
new file mode 100644 (file)
index 0000000..6193db9
--- /dev/null
@@ -0,0 +1,27 @@
+# subclass for testing customizing & subclassing
+
+package MyPerlSource;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use TAP::Parser::Source::Perl;
+
+@ISA = qw( TAP::Parser::Source::Perl MyCustom );
+
+sub _initialize {
+    my $self = shift;
+    $self->SUPER::_initialize(@_);
+    $main::INIT{ ref($self) }++;
+    $self->{initialized} = 1;
+    return $self;
+}
+
+sub source {
+    my $self = shift;
+    return $self->SUPER::source(@_);
+}
+
+1;
+
diff --git a/t/lib/MyResult.pm b/t/lib/MyResult.pm
new file mode 100644 (file)
index 0000000..ab4845d
--- /dev/null
@@ -0,0 +1,21 @@
+# subclass for testing customizing & subclassing
+
+package MyResult;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use TAP::Parser::Result;
+
+@ISA = qw( TAP::Parser::Result MyCustom );
+
+sub _initialize {
+    my $self = shift;
+    $self->SUPER::_initialize(@_);
+    $main::INIT{ ref($self) }++;
+    $self->{initialized} = 1;
+    return $self;
+}
+
+1;
diff --git a/t/lib/MyResultFactory.pm b/t/lib/MyResultFactory.pm
new file mode 100644 (file)
index 0000000..371bba6
--- /dev/null
@@ -0,0 +1,23 @@
+# subclass for testing customizing & subclassing
+
+package MyResultFactory;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use MyResult;
+use TAP::Parser::ResultFactory;
+
+@ISA = qw( TAP::Parser::ResultFactory MyCustom );
+
+sub make_result {
+    my $class = shift;
+
+    # I know, this is not really being initialized, but
+    # for consistency's sake, deal with it :)
+    $main::INIT{$class}++;
+    return MyResult->new(@_);
+}
+
+1;
diff --git a/t/lib/MySource.pm b/t/lib/MySource.pm
new file mode 100644 (file)
index 0000000..5e41b82
--- /dev/null
@@ -0,0 +1,34 @@
+# subclass for testing customizing & subclassing
+
+package MySource;
+
+use strict;
+use vars '@ISA';
+
+use MyCustom;
+use TAP::Parser::Source;
+
+@ISA = qw( TAP::Parser::Source MyCustom );
+
+sub _initialize {
+    my $self = shift;
+    $self->SUPER::_initialize(@_);
+    $main::INIT{ ref($self) }++;
+    $self->{initialized} = 1;
+    return $self;
+}
+
+sub source {
+    my $self = shift;
+    return $self->SUPER::source(@_);
+}
+
+sub get_stream {
+    my $self   = shift;
+    my $stream = $self->SUPER::get_stream(@_);
+
+    # re-bless it:
+    bless $stream, 'MyIterator';
+}
+
+1;
diff --git a/t/lib/TAP/Parser/SubclassTest.pm b/t/lib/TAP/Parser/SubclassTest.pm
new file mode 100644 (file)
index 0000000..84becee
--- /dev/null
@@ -0,0 +1,39 @@
+# subclass for testing subclassing
+
+package TAP::Parser::SubclassTest;
+
+use strict;
+use vars qw(@ISA);
+
+use TAP::Parser;
+
+use MyCustom;
+use MySource;
+use MyPerlSource;
+use MyGrammar;
+use MyIteratorFactory;
+use MyResultFactory;
+
+@ISA = qw( TAP::Parser MyCustom );
+
+sub _default_source_class           {'MySource'}
+sub _default_perl_source_class      {'MyPerlSource'}
+sub _default_grammar_class          {'MyGrammar'}
+sub _default_iterator_factory_class {'MyIteratorFactory'}
+sub _default_result_factory_class   {'MyResultFactory'}
+
+sub make_source      { shift->SUPER::make_source(@_)->custom }
+sub make_perl_source { shift->SUPER::make_perl_source(@_)->custom }
+sub make_grammar     { shift->SUPER::make_grammar(@_)->custom }
+sub make_iterator    { shift->SUPER::make_iterator(@_)->custom }
+sub make_result      { shift->SUPER::make_result(@_)->custom }
+
+sub _initialize {
+    my $self = shift;
+    $self->SUPER::_initialize(@_);
+    $main::INIT{ ref($self) }++;
+    $self->{initialized} = 1;
+    return $self;
+}
+
+1;
diff --git a/t/lib/subclass_tests/non_perl_source b/t/lib/subclass_tests/non_perl_source
new file mode 100644 (file)
index 0000000..12f0f74
--- /dev/null
@@ -0,0 +1,3 @@
+#!/bin/sh
+echo "1..1"
+echo "ok 1 - this is a test"
diff --git a/t/lib/subclass_tests/perl_source b/t/lib/subclass_tests/perl_source
new file mode 100644 (file)
index 0000000..7fef7d5
--- /dev/null
@@ -0,0 +1,6 @@
+#!/usr/bin/perl
+
+print <<'END_TESTS';
+1..1
+ok 1 - this is a test
+END_TESTS