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
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
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
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
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
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
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
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;
use App::Prove::State;
use Carp;
-use vars qw($VERSION);
+@ISA = qw(TAP::Object);
=head1 NAME
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
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';
=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} ) {
$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;
}
'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},
'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
return;
}
-sub _exit { exit( $_[1] || 0 ) }
-
sub _help {
my ( $self, $verbosity ) = @_;
$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';
}
$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} );
}
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);
}
my $aggregator = $harness->runtests(@tests);
- $self->_exit( $aggregator->has_problems ? 1 : 0 );
-
- return;
+ return $aggregator->has_problems ? 0 : 1;
}
sub _get_switches {
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;
}
=item C<exec>
+=item C<extension>
+
=item C<failures>
=item C<fork>
=item C<harness>
+=item C<ignore_exit>
+
=item C<includes>
=item C<jobs>
=item C<recurse>
+=item C<rules>
+
=item C<show_help>
=item C<show_man>
package App::Prove::State;
use strict;
+use vars qw($VERSION @ISA);
+
use File::Find;
use File::Spec;
use Carp;
use TAP::Parser::YAMLish::Writer ();
use TAP::Base;
-use vars qw($VERSION @ISA);
@ISA = qw( TAP::Base );
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
=cut
+# override TAP::Base::new:
sub new {
my $class = shift;
my %args = %{ shift || {} };
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};
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} ) ) {
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;
# Do globbing on Win32.
@argv = map { glob "$_" } @argv if NEED_GLOB;
+ my $extension = $self->{extension};
for my $arg (@argv) {
if ( '-' eq $arg ) {
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;
}
},
package TAP::Base;
use strict;
-use vars qw($VERSION);
+use vars qw($VERSION @ISA);
+
+use TAP::Object;
+
+@ISA = qw(TAP::Object);
=head1 NAME
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
my $GOT_TIME_HIRES;
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.
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 {
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
=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;
}
##############################################################################
my @getter_setters = qw(
_longest
- _tests_without_extensions
_printed_summary_header
_colorizer
);
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
Called by Test::Harness before any test output is generated.
+This is an advisory and may not be called in the case where tests are
+being supplied to Test::Harness by an iterator.
+
=cut
sub prepare {
my $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);
}
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();
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
},
close_test => sub {
+
+ # Avoid circular references
+ $self->parser(undef);
+ $self->{_closures} = {};
+
return if $really_quiet;
if ($show_count) {
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 );
use TAP::Parser;
use TAP::Parser::Aggregator;
use TAP::Parser::Multiplexer;
+use TAP::Parser::Scheduler;
use vars qw($VERSION @ISA);
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
$ENV{HARNESS_ACTIVE} = 1;
$ENV{HARNESS_VERSION} = $VERSION;
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 ) {
(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
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.
$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 };
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;
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;
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;
# 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;
}
}
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);
}
$self->finish_parser( $parser, $session );
- $self->_after_test( $aggregate, $test, $parser );
+ $self->_after_test( $aggregate, $job, $parser );
+ $job->finish;
}
return;
=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
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
=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;
=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 );
}
--- /dev/null
+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;
+
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 );
=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;
qw(
_stream
_spool
- _grammar
exec
exit
is_good_plan
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
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'}
##############################################################################
}
}
+##############################################################################
+
+=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
EOF
);
+ my @class_overrides = qw(
+ source_class
+ perl_source_class
+ grammar_class
+ iterator_factory_class
+ result_factory_class
+ );
+
sub _initialize {
my ( $self, $arg_for ) = @_;
$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(
}
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");
}
$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;
}
return
$self->failed
|| $self->parse_errors
- || $self->wait
- || $self->exit;
+ || ( !$self->ignore_exit && ( $self->wait || $self->exit ) );
}
=head3 C<version>
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
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;
$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');
=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
=item * Matt Kraai
+=item * David Wheeler
+
+=item * Alex Vandiver
+
=back
=head1 AUTHORS
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.
use strict;
use Benchmark;
-use vars qw($VERSION);
+use vars qw($VERSION @ISA);
+
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
=head1 NAME
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 SYNOPSIS
=cut
+# new() implementation supplied by TAP::Object
+
my %SUMMARY_METHOD_FOR;
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} = {};
$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;
goto &todo_passed;
}
-sub _croak {
- my $proto = shift;
- require Carp;
- Carp::croak(@_);
-}
-
=head1 See Also
L<TAP::Parser>
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
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;
}
);
}
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);
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();
my $self = shift;
my $line = $self->{stream}->next;
- return unless defined $line;
+ unless ( defined $line ) {
+ delete $self->{parser}; # break circular ref
+ return;
+ }
my $token;
$token = $self->_make_unknown_token($line) unless $token;
- return TAP::Parser::Result->new($token);
+ return $self->{parser}->make_result($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,
return $data;
}
+1;
+
=head1 TAP GRAMMAR
B<NOTE:> This grammar is slightly out of date. There's still some discussion
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
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
=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;
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 { }
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
+
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
=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 }
}
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
+
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
=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>
}
}
-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";
my $out = IO::Handle->new;
- if ( $class->_use_open3 ) {
+ if ( $self->_use_open3 ) {
# HOTPATCH {{{
my $xclose = \&IPC::Open3::xclose;
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 {
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 ) ) {
}
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
+
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
=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
=cut
-sub new {
- my ( $class, $thing ) = @_;
- bless {
- fh => $thing,
- }, $class;
-}
-
-##############################################################################
-
sub wait { shift->exit }
sub exit { shift->{fh} ? () : 0 }
}
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
+
--- /dev/null
+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
+
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
=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;
}
##############################################################################
unless (@ready) {
return unless $sel->count;
-
- # TODO: Win32 doesn't do select properly on handles...
@ready = $sel->can_read;
}
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 };
}
=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
}
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
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 DESCRIPTION
--- /dev/null
+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
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
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 };
=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
=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;
}
##############################################################################
$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
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
}
##############################################################################
-=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;
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
+
=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
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
my ($filename, @args) = @{ $perl->source };
$perl->source( [ $filename, @args ] );
+C<croak>s if C<$filename> could not be found.
+
=cut
sub source {
=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;
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,
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;
}
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
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
}
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
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
=head1 SYNOPSIS
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
);
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;
#Â Prime the reader
$self->_next;
+ return unless $self->{next};
my $doc = $self->_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;
$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";
=head1 VERSION
-Version 3.10
+Version 3.13
=head1 SYNOPSIS
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;
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;
=head1 VERSION
-Version 3.10
+Version 3.13
=head1 SYNOPSIS
$Timer
$Strap
$has_time_hires
+ $IgnoreExit
);
# $ML $Last_ML_Print
=head1 VERSION
-Version 3.10
+Version 3.13
=cut
-$VERSION = '3.10';
+$VERSION = '3.13';
# Backwards compatibility for exportable variable names.
*verbose = *Verbose;
$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
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;
}
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}
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.
my $app = App::Prove->new;
$app->process_args(@ARGV);
-$app->run;
+exit( $app->run ? 0 : 1 );
__END__
-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.
use strict;
use lib 't/lib';
-use Test::More tests => 62;
+use Test::More tests => 74;
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
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
#!/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';
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 } );
'... 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
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 ');
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' );
}
{
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->();
$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->();
use Test::More tests => 10;
use TAP::Parser;
-use TAP::Parser::Iterator;
+use TAP::Parser::IteratorFactory;
my $tap = <<'END_TAP';
1..5
}
);
-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,
}
},
);
-$stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] );
+$stream = $factory->make_iterator( [ split /\n/ => $tap ] );
$parser = TAP::Parser->new(
{ stream => $stream,
callbacks => \%callbacks,
ELSES => sub { },
);
-$stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] );
+$stream = $factory->make_iterator( [ split /\n/ => $tap ] );
eval {
$parser = TAP::Parser->new(
{ stream => $stream,
: ( 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'; }
#!/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';
}
}
use Test::Harness;
{
+
#28567
unshift @INC, 'wibble';
my @before = Test::Harness::_filtered_inc();
}
use strict;
+
use lib 't/lib';
use Test::More;
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
)
) => {
'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' => '',
}
},
'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
}
},
}
},
'switches' => {
+ 'skip_if' => sub {
+ ( $ENV{PERL5OPT} || '' ) =~ m{(?:^|\s)-[dM]};
+ },
'failed' => {
't/sample-tests/switches' => {
'canon' => 1,
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;
#!/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;
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
# 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 = '';
# _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
# _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);
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';
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;
$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};
+ }
+}
use File::Spec;
use TAP::Parser;
-use TAP::Parser::Iterator;
+use TAP::Parser::IteratorFactory;
use Config;
sub array_ref_from {
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,
return $^O eq 'MSWin32' || $Config{d_fork};
}
+my $factory = TAP::Parser::IteratorFactory->new;
for my $test (@schedule) {
SKIP: {
my $name = $test->{name};
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';
# 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';
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';
# coverage test for VMS case
- my $stream = TAP::Parser::Iterator->new(
+ my $stream = $factory->make_iterator(
[ 'not ',
'ok 1 - I hate VMS',
]
# coverage test for VMS case - nothing after 'not'
- $stream = TAP::Parser::Iterator->new(
+ $stream = $factory->make_iterator(
[ 'not ',
]
);
eval {
local $SIG{__DIE__} = sub { push @die, @_ };
- TAP::Parser::Iterator->new( {} );
+ $factory->make_iterator( {} );
};
is @die, 1, 'coverage testing for TPI::Process';
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' )
}
);
- 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
return [
TAP::Parser->new(
{ source => File::Spec->catfile(
- ($ENV{PERL_CORE} ? 'lib' : 't'), 'sample-tests',
- 'simple'
+ ( $ENV{PERL_CORE} ? 'lib' : 't' ), 'sample-tests',
+ 'simple'
),
}
),
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'
),
}
),
( map {
[ TAP::Parser->new(
{ source => File::Spec->catfile(
- ($ENV{PERL_CORE} ? 'lib' : 't'),
- 'sample-tests', 'simple'
+ ( $ENV{PERL_CORE} ? 'lib' : 't' ),
+ 'sample-tests', 'simple'
),
}
),
--- /dev/null
+#!/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' );
+
}
}
-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;
TAP::Parser::Result::Version
);
+my $factory = TAP::Parser::IteratorFactory->new;
+
my $tap = <<'END_TAP';
TAP version 13
1..7
'... 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';
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?
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
_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
_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
$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';
}
{
@ISA = qw(TAP::Parser::Iterator);
- sub new {
- return bless {}, shift;
- }
-
sub next_raw {
die 'this is the dying iterator';
}
$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);
$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);
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 }
+ )
+ );
+ }
+}
--- /dev/null
+#!/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...
--- /dev/null
+#!/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' );
+}
use Test::More tests => 14;
use TAP::Parser;
-use TAP::Parser::Iterator;
+use TAP::Parser::IteratorFactory;
sub tap_to_lines {
my $string = shift;
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) ),
}
);
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 ) ] ),
}
);
$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;
'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 ) {
# 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
--- /dev/null
+#!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';
+}
},
);
- plan tests => @SCHEDULE * 2;
+ plan tests => @SCHEDULE * 3;
}
# Waaaaay too much boilerplate
return $self;
}
-sub _exit {
- my $self = shift;
- push @{ $self->{_log} }, [ '_exit', @_ ];
- die "Exited";
-}
-
sub get_log {
my $self = shift;
my @log = @{ $self->{_log} };
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;
# 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();
passed => TRUE,
is_ok => TRUE,
directive => 'SKIP',
- explanation => 'rope'
+ explanation => ''
},
],
plan => '1..0',
'exit' => 0,
wait => 0,
version => 12,
- skip_all => 'rope',
+ skip_all => '(no reason given)',
},
skipall_v13 => {
results => [
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';
# found in the regression tests.
#
+my $factory = TAP::Parser::ResultFactory->new;
my %inherited_methods = (
is_plan => '',
is_test => '',
'... 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
#
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;
--- /dev/null
+#!/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";
+}
+
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'
);
'... 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';
'... 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';
# coverage for method get_steam
- my $source = TAP::Parser::Source->new();
+ my $source = TAP::Parser::Source->new( { parser => $parser } );
my @die;
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';
-}
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 ] )
}
);
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',
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,
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';
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';
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;
my %make_test;
BEGIN {
+
# TODO: Investigate failure on 5.8.0
plan skip_all => "unicode on Perl <= 5.8.0"
unless $] > 5.008;
-#!/usr/bin/perl -w
+#!perl -w
use strict;
use lib 't/lib';
],
out => "Hello, World\n",
},
+ { name => 'Hello World Block',
+ in => [
+ '--- |',
+ ' Hello,',
+ ' World',
+ '...',
+ ],
+ out => "Hello,\n World\n",
+ },
{ name => 'Hello World 5',
in => [
'--- >',
six => '6'
},
},
-
+ { name => 'Space after colon',
+ in => [ '---', 'spog: ', ' - 1', ' - 2', '...' ],
+ out => { spog => [ 1, 2 ] },
+ },
{ name => 'Original YAML::Tiny test',
in => [
'---',
"\n\t" => 'newline, tab',
},
},
+ { name => 'Empty',
+ in => [],
+ out => undef,
+ },
);
plan tests => @SCHEDULE * 5;
package App::Prove::Plugin::Dummy;
sub import {
- main::test_log_import( @_ );
+ main::test_log_import(@_);
}
1;
--- /dev/null
+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;
--- /dev/null
+# avoid cut-n-paste exhaustion with this mixin
+
+package MyCustom;
+use strict;
+
+sub custom {
+ my $self = shift;
+ $main::CUSTOM{ ref($self) }++;
+ return $self;
+}
+
+1;
--- /dev/null
+# 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;
--- /dev/null
+# 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;
--- /dev/null
+# 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;
--- /dev/null
+# 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;
+
--- /dev/null
+# 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;
--- /dev/null
+# 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;
--- /dev/null
+# 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;
--- /dev/null
+# 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;
--- /dev/null
+#!/bin/sh
+echo "1..1"
+echo "ok 1 - this is a test"
--- /dev/null
+#!/usr/bin/perl
+
+print <<'END_TESTS';
+1..1
+ok 1 - this is a test
+END_TESTS
projects / p5sagit/p5-mst-13.2.git / commitdiff