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