diff options
| author | Chris 'BinGOs' Williams <chris@bingosnet.co.uk> | 2010-06-29 10:16:45 +0100 |
|---|---|---|
| committer | Chris 'BinGOs' Williams <chris@bingosnet.co.uk> | 2010-06-29 10:16:45 +0100 |
| commit | 6d3136644eb73f7a0727d341c90937f4234835bf (patch) | |
| tree | 5d33927fe3fa23eedb65329c17a9eaffa9af71c3 /cpan | |
| parent | 8f4d46e2e6b66d00df1e347dab564fd9799c8d94 (diff) | |
| download | perl-6d3136644eb73f7a0727d341c90937f4234835bf.tar.gz | |
Update Test-Harness to CPAN version 3.21
Mark UPSTREAM as 'cpan' in Maintainers.pl
[DELTA]
3.21 2010-01-30
- Add test to ensure we're not depending on a module we no
longer ship.
- Fix up skip counts for Windows case - tests were failing
on Windows.
3.20 2010-01-22
- Remove references / dependency on TAP::Parser::Source::Perl
3.19 2010-01-20
- Avoid depending on Module::Build. The resulting circular
dependency made it impossible to install Test::Harness and/or
Module::Build in some cases.
3.18 2010-01-19
- Handle the case where the filename of the perl executable
contains space. Thanks to kmx.
- Various documentation fixes.
3.17_04 2010-01-04
- Fix failures due to unknown location of Perl in t/source_handler.t.
- Use EUMM style shebang magic to produce an executable 'psql'
for t/source_handler.t.
3.17_03 2009-11-19
- Fix failures due to over-strict assertions in t/source.t.
3.17_02 2009-11-17
- Merge in Steve's missing changes. Oops.
3.17_01 2009-11-17
- Re-engineered source handling API to allow users to configure how
TAP is sourced by the parser. Introduced a new 'sources' param to
TAP::Harness, and new options to prove, eg:
prove --source XYZ --xyz-option foo=bar
The new TAP::Parser::SourceHandler API makes it much easier to
write plugins. This breaks backwards compatibility for plugins &
extenstions that rely on the following APIs:
TAP::Parser::Source
TAP::Parser::SourceFactory
TAP::Parser::IteratorFactory
TAP::Parser, specifically:
new: 'source' & 'tap' params
source_class
perl_source_class
iterator_factory_class
make_source
make_perl_source
make_iterator
Please see the TAP::Parser docs for more details.
[Steve Purkis & David Wheeler]
- Removed dependency on File::Spec [Schwern]
- Made it possible to pass different args to each test [Lee Johnson]
- Added HARNESS_SUBCLASS option to Test::Harness
- Added TAP::Parser::SourceHandler::File which lets you to stream TAP
from a text file (eg: *.tap).
- Added TAP::Parser::SourceHandler::pgTAP. All the source handlers are
new, but this is the only one to add major new functioality: the
ability to run pgTAP tests (http://pgtap.projects.postgresql.org/).
Diffstat (limited to 'cpan')
112 files changed, 5039 insertions, 1451 deletions
diff --git a/cpan/Test-Harness/Changes b/cpan/Test-Harness/Changes index 6141f78f36..098853a2da 100644 --- a/cpan/Test-Harness/Changes +++ b/cpan/Test-Harness/Changes @@ -1,5 +1,69 @@ Revision history for Test-Harness +3.21 2010-01-30 + - Add test to ensure we're not depending on a module we no + longer ship. + - Fix up skip counts for Windows case - tests were failing + on Windows. + +3.20 2010-01-22 + - Remove references / dependency on TAP::Parser::Source::Perl + +3.19 2010-01-20 + - Avoid depending on Module::Build. The resulting circular + dependency made it impossible to install Test::Harness and/or + Module::Build in some cases. + +3.18 2010-01-19 + - Handle the case where the filename of the perl executable + contains space. Thanks to kmx. + - Various documentation fixes. + +3.17_04 2010-01-04 + - Fix failures due to unknown location of Perl in t/source_handler.t. + - Use EUMM style shebang magic to produce an executable 'psql' + for t/source_handler.t. + +3.17_03 2009-11-19 + - Fix failures due to over-strict assertions in t/source.t. + +3.17_02 2009-11-17 + - Merge in Steve's missing changes. Oops. + +3.17_01 2009-11-17 + - Re-engineered source handling API to allow users to configure how + TAP is sourced by the parser. Introduced a new 'sources' param to + TAP::Harness, and new options to prove, eg: + + prove --source XYZ --xyz-option foo=bar + + The new TAP::Parser::SourceHandler API makes it much easier to + write plugins. This breaks backwards compatibility for plugins & + extenstions that rely on the following APIs: + + TAP::Parser::Source + TAP::Parser::SourceFactory + TAP::Parser::IteratorFactory + TAP::Parser, specifically: + new: 'source' & 'tap' params + source_class + perl_source_class + iterator_factory_class + make_source + make_perl_source + make_iterator + + Please see the TAP::Parser docs for more details. + [Steve Purkis & David Wheeler] + - Removed dependency on File::Spec [Schwern] + - Made it possible to pass different args to each test [Lee Johnson] + - Added HARNESS_SUBCLASS option to Test::Harness + - Added TAP::Parser::SourceHandler::File which lets you to stream TAP + from a text file (eg: *.tap). + - Added TAP::Parser::SourceHandler::pgTAP. All the source handlers are + new, but this is the only one to add major new functioality: the + ability to run pgTAP tests (http://pgtap.projects.postgresql.org/). + 3.17 2009-05-05 - Changed the 'failures' so that it is overridden by verbosity rather than the other way around. diff --git a/cpan/Test-Harness/bin/prove b/cpan/Test-Harness/bin/prove index a592a80f0d..8264171431 100644..100755 --- a/cpan/Test-Harness/bin/prove +++ b/cpan/Test-Harness/bin/prove @@ -21,50 +21,54 @@ prove - Run tests through a TAP harness. Boolean options: - -v, --verbose Print all test lines. - -l, --lib Add 'lib' to the path for your tests (-Ilib). - -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. - --count Show the X/Y test count when not verbose (default) - --nocount Disable the X/Y test count. - -D --dry Dry run. Show test that would have run. - --ext Set the extension for tests (default '.t') - -f, --failures Show failed tests. - -o, --comments Show comments. - --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. - -q, --quiet Suppress some test output while running tests. - -Q, --QUIET Only print summary results. - -p, --parse Show full list of TAP parse errors, if any. - --directives Only show results with TODO or SKIP directives. - --timer Print elapsed time after each test. - --normalize Normalize TAP output in verbose output - -T Enable tainting checks. - -t Enable tainting warnings. - -W Enable fatal warnings. - -w Enable warnings. - -h, --help Display this help - -?, Display this help - -H, --man Longer manpage for prove - --norc Don't process default .proverc + -v, --verbose Print all test lines. + -l, --lib Add 'lib' to the path for your tests (-Ilib). + -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. + --count Show the X/Y test count when not verbose + (default) + --nocount Disable the X/Y test count. + -D --dry Dry run. Show test that would have run. + --ext Set the extension for tests (default '.t') + -f, --failures Show failed tests. + -o, --comments Show comments. + --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. + -q, --quiet Suppress some test output while running tests. + -Q, --QUIET Only print summary results. + -p, --parse Show full list of TAP parse errors, if any. + --directives Only show results with TODO or SKIP directives. + --timer Print elapsed time after each test. + --normalize Normalize TAP output in verbose output + -T Enable tainting checks. + -t Enable tainting warnings. + -W Enable fatal warnings. + -w Enable warnings. + -h, --help Display this help + -?, Display this help + -H, --man Longer manpage for prove + --norc Don't process default .proverc Options that take arguments: - -I Library paths to include. - -P Load plugin (searches App::Prove::Plugin::*.) - -M Load a module. - -e, --exec Interpreter to run the tests ('' for compiled tests.) - --harness Define test harness to use. See TAP::Harness. - --formatter Result formatter to use. See TAP::Harness. - -a, --archive Store the resulting TAP in an archive file. - -j, --jobs N Run N test jobs in parallel (try 9.) - --state=opts Control prove's persistent state. - --rc=rcfile Process options from rcfile + -I Library paths to include. + -P Load plugin (searches App::Prove::Plugin::*.) + -M Load a module. + -e, --exec Interpreter to run the tests ('' for compiled + tests.) + --harness Define test harness to use. See TAP::Harness. + --formatter Result formatter to use. See FORMATTERS. + --source Load and/or configure a SourceHandler. See + SOURCE HANDLERS. + -a, --archive out.tgz Store the resulting TAP in an archive file. + -j, --jobs N Run N test jobs in parallel (try 9.) + --state=opts Control prove's persistent state. + --rc=rcfile Process options from rcfile =head1 NOTES @@ -76,7 +80,7 @@ in F<.proverc> are specified in the same way as command line options: # .proverc --state=hot,fast,save - -j9 --fork + -j9 Additional option files may be specified with the C<--rc> option. Default option file processing is disabled by the C<--norc> option. @@ -101,7 +105,7 @@ matching the pattern C<t/*.t>. =head2 Colored Test Output Colored test output is the default, but if output is not to a -terminal, color is disabled. You can override this by adding the +terminal, color is disabled. You can override this by adding the C<--color> switch. Color support requires L<Term::ANSIColor> on Unix-like platforms and @@ -118,7 +122,7 @@ It is possible to supply arguments to tests. To do so separate them from prove's own arguments with the arisdottle, '::'. For example prove -v t/mytest.t :: --url http://example.com - + would run F<t/mytest.t> with the options '--url http://example.com'. When running multiple tests they will each receive the same arguments. @@ -137,7 +141,7 @@ switch: If you need to make sure your diagnostics are displayed in the correct order relative to test results you can use the C<--merge> option to -merge the test scripts' STDERR into their STDOUT. +merge the test scripts' STDERR into their STDOUT. This guarantees that STDOUT (where the test results appear) and STDOUT (where the diagnostics appear) will stay in sync. The harness will @@ -175,7 +179,7 @@ Run only the tests that failed on the last run. # Run all tests $ prove -b --state=save - + # Run failures $ prove -b --state=failed @@ -224,7 +228,7 @@ Run the tests in slowest to fastest order. This is useful in conjunction with the C<-j> parallel testing switch to ensure that your slowest tests start running first. - $ prove -b --state=slow -j9 + $ prove -b --state=slow -j9 =item C<fast> @@ -268,11 +272,40 @@ via the C<-Ilib> option to F<prove>. Normally when a Perl program is run in taint mode the contents of the C<PERL5LIB> environment variable do not appear in C<@INC>. -Because C<PERL5LIB> is often used during testing to add build directories -to C<@INC> prove (actually L<TAP::Parser::Source::Perl>) passes the -names of any directories found in C<PERL5LIB> as -I switches. The net -effect of this is that C<PERL5LIB> is honoured even when prove is run in -taint mode. +Because C<PERL5LIB> is often used during testing to add build +directories to C<@INC> prove passes the names of any directories found +in C<PERL5LIB> as -I switches. The net effect of this is that +C<PERL5LIB> is honoured even when prove is run in taint mode. + + +=head1 FORMATTERS + +You can load a custom L<TAP::Parser::Formatter>: + + prove --formatter MyFormatter + +=head1 SOURCE HANDLERS + +You can load custom L<TAP::Parser::SourceHandler>s, to change the way the +parser interprets particular I<sources> of TAP. + + prove --source MyHandler --source YetAnother t + +If you want to provide config to the source you can use: + + prove --source MyCustom \ + --source Perl --perl-option 'foo=bar baz' --perl-option avg=0.278 \ + --source File --file-option extensions=.txt --file-option extensions=.tmp t + +Each C<--$source-option> option must specify a key/value pair separated by an +C<=>. If an option can take multiple values, just specify it multiple times, +as with the C<extensions=> examples above. + +All C<--sources> are combined into a hash, and passed to L<TAP::Harness/new>'s +C<sources> parameter. + +See L<TAP::Parser::IteratorFactory> for more details on how configuration is +passed to I<SourceHandlers>. =head1 PLUGINS diff --git a/cpan/Test-Harness/lib/App/Prove.pm b/cpan/Test-Harness/lib/App/Prove.pm index fd431ed2f0..ca1dbda01c 100644 --- a/cpan/Test-Harness/lib/App/Prove.pm +++ b/cpan/Test-Harness/lib/App/Prove.pm @@ -17,11 +17,11 @@ App::Prove - Implements the C<prove> command. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION @@ -59,7 +59,7 @@ BEGIN { really_quiet recurse backwards shuffle taint_fail taint_warn timer verbose warnings_fail warnings_warn show_help show_man show_version state_class test_args state dry extension ignore_exit rules state_manager - normalize + normalize sources ); __PACKAGE__->mk_methods(@ATTR); } @@ -82,7 +82,9 @@ sub _initialize { my $args = shift || {}; # setup defaults: - for my $key (qw( argv rc_opts includes modules state plugins rules )) { + for my $key ( + qw( argv rc_opts includes modules state plugins rules sources )) + { $self->{$key} = []; } $self->{harness_class} = 'TAP::Harness'; @@ -197,7 +199,7 @@ sub process_args { { local @ARGV = @args; - Getopt::Long::Configure( 'no_ignore_case', 'bundling' ); + Getopt::Long::Configure(qw(no_ignore_case bundling pass_through)); # Don't add coderefs to GetOptions GetOptions( @@ -215,6 +217,7 @@ sub process_args { 'ext=s' => \$self->{extension}, 'harness=s' => \$self->{harness}, 'ignore-exit' => \$self->{ignore_exit}, + 'source=s@' => $self->{sources}, 'formatter=s' => \$self->{formatter}, 'r|recurse' => \$self->{recurse}, 'reverse' => \$self->{backwards}, @@ -310,6 +313,11 @@ sub _get_args { $args{formatter_class} = $formatter; } + for my $handler ( @{ $self->sources } ) { + my ( $name, $config ) = $self->_parse_source($handler); + $args{sources}->{$name} = $config; + } + if ( $self->ignore_exit ) { $args{ignore_exit} = 1; } @@ -411,6 +419,30 @@ sub _load_extensions { $self->_load_extension( $_, @search ) for @$ext; } +sub _parse_source { + my ( $self, $handler ) = @_; + + # Load any options. + ( my $opt_name = lc $handler ) =~ s/::/-/g; + local @ARGV = @{ $self->{argv} }; + my %config; + Getopt::Long::GetOptions( + "$opt_name-option=s%" => sub { + my ( undef, $k, $v ) = @_; + if ( exists $config{$k} ) { + $config{$k} = [ $config{$k} ] + unless ref $config{$k} eq 'ARRAY'; + push @{ $config{$k} } => $v; + } + else { + $config{$k} = $v; + } + } + ); + $self->{argv} = \@ARGV; + return ( $handler, \%config ); +} + =head3 C<run> Perform whatever actions the command line args specified. The C<prove> diff --git a/cpan/Test-Harness/lib/App/Prove/State.pm b/cpan/Test-Harness/lib/App/Prove/State.pm index 202f7aadd3..a1e821c5b9 100644 --- a/cpan/Test-Harness/lib/App/Prove/State.pm +++ b/cpan/Test-Harness/lib/App/Prove/State.pm @@ -26,11 +26,11 @@ App::Prove::State - State storage for the C<prove> command. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/App/Prove/State/Result.pm b/cpan/Test-Harness/lib/App/Prove/State/Result.pm index 274676a62f..9d6cbd32f4 100644 --- a/cpan/Test-Harness/lib/App/Prove/State/Result.pm +++ b/cpan/Test-Harness/lib/App/Prove/State/Result.pm @@ -14,11 +14,11 @@ App::Prove::State::Result - Individual test suite results. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION @@ -223,7 +223,7 @@ sub raw { my %raw = %$self; my %tests; - foreach my $test ( $self->tests ) { + for my $test ( $self->tests ) { $tests{ $test->name } = $test->raw; } $raw{tests} = \%tests; diff --git a/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm b/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm index 231f78919e..993699ce64 100644 --- a/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm +++ b/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm @@ -10,11 +10,11 @@ App::Prove::State::Result::Test - Individual test results. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Base.pm b/cpan/Test-Harness/lib/TAP/Base.pm index f88ad11134..8285240d39 100644 --- a/cpan/Test-Harness/lib/TAP/Base.pm +++ b/cpan/Test-Harness/lib/TAP/Base.pm @@ -14,11 +14,11 @@ and L<TAP::Harness> =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; use constant GOT_TIME_HIRES => do { eval 'use Time::HiRes qw(time);'; diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Base.pm b/cpan/Test-Harness/lib/TAP/Formatter/Base.pm index f2b54a9ba3..2ff384e0f5 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Base.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Base.pm @@ -43,15 +43,15 @@ BEGIN { =head1 NAME -TAP::Formatter::Console - Harness output delegate for default console output +TAP::Formatter::Base - Base class for harness output delegates =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION @@ -206,7 +206,7 @@ sub prepare { my $longest = 0; - foreach my $test (@tests) { + for my $test (@tests) { $longest = length $test if length $test > $longest; } @@ -290,7 +290,7 @@ sub summary { if ( $total != $passed or $aggregate->has_problems ) { $self->_output("\nTest Summary Report"); $self->_output("\n-------------------\n"); - foreach my $test (@$tests) { + for my $test (@$tests) { $self->_printed_summary_header(0); my ($parser) = $aggregate->parsers($test); $self->_output_summary_failure( @@ -330,7 +330,7 @@ sub summary { sprintf " Parse errors: %s\n", shift @errors ); - foreach my $error (@errors) { + for my $error (@errors) { my $spaces = ' ' x 16; $self->_failure_output("$spaces$error\n"); } @@ -422,7 +422,7 @@ sub _range { @numbers = sort { $a <=> $b } @numbers; my ( $min, @range ); - foreach my $i ( 0 .. $#numbers ) { + for my $i ( 0 .. $#numbers ) { my $num = $numbers[$i]; my $next = $numbers[ $i + 1 ]; if ( defined $next && $next == $num + 1 ) { diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Color.pm b/cpan/Test-Harness/lib/TAP/Formatter/Color.pm index 349d3b84bf..ea2eebe298 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Color.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Color.pm @@ -71,11 +71,11 @@ TAP::Formatter::Color - Run Perl test scripts with color =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Console.pm b/cpan/Test-Harness/lib/TAP/Formatter/Console.pm index aeca2f2b0d..8463a39abd 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Console.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Console.pm @@ -14,11 +14,11 @@ TAP::Formatter::Console - Harness output delegate for default console output =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION @@ -31,7 +31,7 @@ This provides console orientated output formatting for TAP::Harness. =head2 C<< open_test >> -See L<TAP::Formatter::base> +See L<TAP::Formatter::Base> =cut diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm b/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm index b6b5134cda..47c4aca5b0 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm @@ -42,11 +42,11 @@ TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION @@ -94,7 +94,7 @@ sub _output_ruler { my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start; - foreach my $active ( @{ $context->{active} } ) { + for my $active ( @{ $context->{active} } ) { my $parser = $active->parser; my $tests = $parser->tests_run; my $planned = $parser->tests_planned || '?'; diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm b/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm index 675512c71d..e24cb6ca25 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm @@ -28,11 +28,11 @@ TAP::Formatter::Console::Session - Harness output delegate for default console o =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/File.pm b/cpan/Test-Harness/lib/TAP/Formatter/File.pm index 8514bc068b..38c8b490aa 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/File.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/File.pm @@ -15,11 +15,11 @@ TAP::Formatter::File - Harness output delegate for file output =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm b/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm index c6abfd63bc..a97422400d 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm @@ -13,11 +13,11 @@ TAP::Formatter::File::Session - Harness output delegate for file output =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Session.pm b/cpan/Test-Harness/lib/TAP/Formatter/Session.pm index 21767e5eba..250b6f9fad 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Session.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Session.pm @@ -25,11 +25,11 @@ TAP::Formatter::Session - Abstract base class for harness output delegate =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 METHODS diff --git a/cpan/Test-Harness/lib/TAP/Harness.pm b/cpan/Test-Harness/lib/TAP/Harness.pm index 749e7af416..4774c0039c 100644 --- a/cpan/Test-Harness/lib/TAP/Harness.pm +++ b/cpan/Test-Harness/lib/TAP/Harness.pm @@ -19,11 +19,11 @@ TAP::Harness - Run test scripts with statistics =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; $ENV{HARNESS_ACTIVE} = 1; $ENV{HARNESS_VERSION} = $VERSION; @@ -84,6 +84,7 @@ BEGIN { test_args => sub { shift; shift }, ignore_exit => sub { shift; shift }, rules => sub { shift; shift }, + sources => sub { shift; shift }, ); for my $method ( sort keys %VALIDATION_FOR ) { @@ -192,6 +193,16 @@ only makes sense in the context of tests written in Perl. A reference to an C<@INC> style array of arguments to be passed to each test program. + test_args => ['foo', 'bar'], + +if you want to pass different arguments to each test then you should +pass a hash of arrays, keyed by the alias for each test: + + test_args => { + my_test => ['foo', 'bar'], + other_test => ['baz'], + } + =item * C<color> Attempt to produce color output. @@ -229,6 +240,29 @@ will be interpreted as raw TAP or as a TAP stream, respectively. If C<merge> is true the harness will create parsers that merge STDOUT and STDERR together for any processes they start. +=item * C<sources> + +I<NEW to 3.18>. + +If set, C<sources> must be a hashref containing the names of the +L<TAP::Parser::SourceHandler>s to load and/or configure. The values are a +hash of configuration that will be accessible to to the source handlers via +L<TAP::Parser::Source/config_for>. + +For example: + + sources => { + Perl => { exec => '/path/to/custom/perl' }, + File => { extensions => [ '.tap', '.txt' ] }, + MyCustom => { some => 'config' }, + } + +The C<sources> parameter affects how C<source>, C<tap> and C<exec> parameters +are handled. + +For more details, see the C<sources> parameter in L<TAP::Parser/new>, +L<TAP::Parser::Source>, and L<TAP::Parser::IteratorFactory>. + =item * C<aggregator_class> The name of the class to use to aggregate test results. The default is @@ -393,7 +427,7 @@ Any keys for which the value is C<undef> will be ignored. $harness->runtests(@tests); -Accepts and array of C<@tests> to be run. This should generally be the +Accepts an array of C<@tests> to be run. This should generally be the names of test files, but this is not required. Each element in C<@tests> will be passed to C<TAP::Parser::new()> as a C<source>. See L<TAP::Parser> for more information. @@ -437,7 +471,9 @@ sub runtests { =head3 C<summary> -Output the summary for a TAP::Parser::Aggregator. + $harness->summary( $aggregator ); + +Output the summary for a L<TAP::Parser::Aggregator>. =cut @@ -533,7 +569,7 @@ sub _aggregate_single { $harness->aggregate_tests( $aggregate, @tests ); Run the named tests and display a summary of result. Tests will be run -in the order found. +in the order found. Test results will be added to the supplied L<TAP::Parser::Aggregator>. C<aggregate_tests> may be called multiple times to run several sets of @@ -561,20 +597,23 @@ are unsuitable for parallel execution. Note that for simpler testing requirements it will often be possible to replace the above code with a single call to C<runtests>. -Each elements of the @tests array is either +Each element of the C<@tests> array is either: =over -=item * the file name of a test script to run +=item * the source name of a test to run -=item * a reference to a [ file name, display name ] array +=item * a reference to a [ source name, display name ] array =back +In the case of a perl test suite, typically I<source names> are simply the file +names of the test scripts to run. + When you supply a separate display name it becomes possible to run a test more than once; the display name is effectively the alias by which the test is known inside the harness. The harness doesn't care if it -runs the same script more than once when each invocation uses a +runs the same test more than once when each invocation uses a different name. =cut @@ -639,59 +678,13 @@ should be set higher. ############################################################################## -=head1 SUBCLASSING - -C<TAP::Harness> is designed to be (mostly) easy to subclass. If you -don't like how a particular feature functions, just override the -desired methods. - -=head2 Methods - -TODO: This is out of date - -The following methods are ones you may wish to override if you want to -subclass C<TAP::Harness>. - -=head3 C<summary> - - $harness->summary( \%args ); - -C<summary> prints the summary report after all tests are run. The -argument is a hashref with the following keys: - -=over 4 - -=item * C<start> - -This is created with C<< Benchmark->new >> and it the time the tests -started. You can print a useful summary time, if desired, with: - - $self->output( - timestr( timediff( Benchmark->new, $start_time ), 'nop' ) ); - -=item * C<tests> - -This is an array reference of all test names. To get the L<TAP::Parser> -object for individual tests: - - my $aggregate = $args->{aggregate}; - my $tests = $args->{tests}; - - for my $name ( @$tests ) { - my ($parser) = $aggregate->parsers($test); - ... do something with $parser - } - -This is a bit clunky and will be cleaned up in a later release. - -=back - -=cut - sub _get_parser_args { my ( $self, $job ) = @_; my $test_prog = $job->filename; my %args = (); + + $args{sources} = $self->sources if $self->sources; + my @switches; @switches = $self->lib if $self->lib; push @switches => $self->switches if $self->switches; @@ -717,6 +710,19 @@ sub _get_parser_args { } if ( defined( my $test_args = $self->test_args ) ) { + + if ( ref($test_args) eq 'HASH' ) { + + # different args for each test + if ( exists( $test_args->{ $job->description } ) ) { + $test_args = $test_args->{ $job->description }; + } + else { + $self->_croak( "TAP::Harness Can't find test_args for " + . $job->description ); + } + } + $args{test_args} = $test_args; } @@ -807,6 +813,120 @@ sub _croak { return; } +1; + +__END__ + +############################################################################## + +=head1 CONFIGURING + +C<TAP::Harness> is designed to be easy to configure. + +=head2 Plugins + +C<TAP::Parser> plugins let you change the way TAP is I<input> to and I<output> +from the parser. + +L<TAP::Parser::SourceHandler>s handle TAP I<input>. You can configure them +and load custom handlers using the C<sources> parameter to L</new>. + +L<TAP::Formatter>s handle TAP I<output>. You can load custom formatters by +using the C<formatter_class> parameter to L</new>. To configure a formatter, +you currently need to instantiate it outside of L<TAP::Harness> and pass it in +with the C<formatter> parameter to L</new>. This I<may> be addressed by adding +a I<formatters> parameter to L</new> in the future. + +=head2 C<Module::Build> + +L<Module::Build> version C<0.30> supports C<TAP::Harness>. + +To load C<TAP::Harness> plugins, you'll need to use the C<tap_harness_args> +parameter to C<new>, typically from your C<Build.PL>. For example: + + Module::Build->new( + module_name => 'MyApp', + test_file_exts => [qw(.t .tap .txt)], + use_tap_harness => 1, + tap_harness_args => { + sources => { + MyCustom => {}, + File => { + extensions => ['.tap', '.txt'], + }, + }, + formatter => 'TAP::Formatter::HTML', + }, + build_requires => { + 'Module::Build' => '0.30', + 'TAP::Harness' => '3.18', + }, + )->create_build_script; + +See L</new> + +=head2 C<ExtUtils::MakeMaker> + +L<ExtUtils::MakeMaker> does not support L<TAP::Harness> out-of-the-box. + +=head2 C<prove> + +L<prove> supports C<TAP::Harness> plugins, and has a plugin system of its +own. See L<prove/FORMATTERS>, L<prove/SOURCE HANDLERS> and L<App::Prove> +for more details. + +=head1 WRITING PLUGINS + +If you can't configure C<TAP::Harness> to do what you want, and you can't find +an existing plugin, consider writing one. + +The two primary use cases supported by L<TAP::Harness> for plugins are I<input> +and I<output>: + +=over 2 + +=item Customize how TAP gets into the parser + +To do this, you can either extend an existing L<TAP::Parser::SourceHandler>, +or write your own. It's a pretty simple API, and they can be loaded and +configured using the C<sources> parameter to L</new>. + +=item Customize how TAP results are output from the parser + +To do this, you can either extend an existing L<TAP::Formatter>, or write your +own. Writing formatters are a bit more involved than writing a +I<SourceHandler>, as you'll need to understand the L<TAP::Parser> API. A +good place to start is by understanding how L</aggregate_tests> works. + +Custom formatters can be loaded configured using the C<formatter_class> +parameter to L</new>. + +=back + +=head1 SUBCLASSING + +If you can't configure C<TAP::Harness> to do exactly what you want, and writing +a plugin isn't an option, consider extending it. It is designed to be (mostly) +easy to subclass, though the cases when sub-classing is necessary should be few +and far between. + +=head2 Methods + +The following methods are ones you may wish to override if you want to +subclass C<TAP::Harness>. + +=over 4 + +=item L</new> + +=item L</runtests> + +=item L</summary> + +=back + +=cut + =head1 REPLACING If you like the C<prove> utility and L<TAP::Parser> but you want your @@ -825,6 +945,4 @@ L<Test::Harness> =cut -1; - # vim:ts=4:sw=4:et:sta diff --git a/cpan/Test-Harness/lib/TAP/Harness/Beyond.pod b/cpan/Test-Harness/lib/TAP/Harness/Beyond.pod new file mode 100644 index 0000000000..8704f52b28 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Harness/Beyond.pod @@ -0,0 +1,416 @@ +=head1 Beyond make test + +Test::Harness is responsible for running test scripts, analysing +their output and reporting success or failure. When I type +F<make test> (or F<./Build test>) for a module, Test::Harness is usually +used to run the tests (not all modules use Test::Harness but the +majority do). + +To start exploring some of the features of Test::Harness I need to +switch from F<make test> to the F<prove> command (which ships with +Test::Harness). For the following examples I'll also need a recent +version of Test::Harness installed; 3.14 is current as I write. + +For the examples I'm going to assume that we're working with a +'normal' Perl module distribution. Specifically I'll assume that +typing F<make> or F<./Build> causes the built, ready-to-install module +code to be available below ./blib/lib and ./blib/arch and that +there's a directory called 't' that contains our tests. Test::Harness +isn't hardwired to that configuration but it saves me from explaining +which files live where for each example. + +Back to F<prove>; like F<make test> it runs a test suite - but it +provides far more control over which tests are executed, in what +order and how their results are reported. Typically F<make test> +runs all the test scripts below the 't' directory. To do the same +thing with prove I type: + + prove -rb t + +The switches here are -r to recurse into any directories below 't' +and -b which adds ./blib/lib and ./blib/arch to Perl's include path +so that the tests can find the code they will be testing. If I'm +testing a module of which an earlier version is already installed +I need to be careful about the include path to make sure I'm not +running my tests against the installed version rather than the new +one that I'm working on. + +Unlike F<make test>, typing F<prove> doesn't automatically rebuild +my module. If I forget to make before prove I will be testing against +older versions of those files - which inevitably leads to confusion. +I either get into the habit of typing + + make && prove -rb t + +or - if I have no XS code that needs to be built I use the modules +below F<lib> instead + + prove -Ilib -r t + +So far I've shown you nothing that F<make test> doesn't do. Let's +fix that. + +=head2 Saved State + +If I have failing tests in a test suite that consists of more than +a handful of scripts and takes more than a few seconds to run it +rapidly becomes tedious to run the whole test suite repeatedly as +I track down the problems. + +I can tell prove just to run the tests that are failing like this: + + prove -b t/this_fails.t t/so_does_this.t + +That speeds things up but I have to make a note of which tests are +failing and make sure that I run those tests. Instead I can use +prove's --state switch and have it keep track of failing tests for +me. First I do a complete run of the test suite and tell prove to +save the results: + + prove -rb --state=save t + +That stores a machine readable summary of the test run in a file +called '.prove' in the current directory. If I have failures I can +then run just the failing scripts like this: + + prove -b --state=failed + +I can also tell prove to save the results again so that it updates +its idea of which tests failed: + + prove -b --state=failed,save + +As soon as one of my failing tests passes it will be removed from +the list of failed tests. Eventually I fix them all and prove can +find no failing tests to run: + + Files=0, Tests=0, 0 wallclock secs ( 0.00 usr + 0.00 sys = 0.00 CPU) + Result: NOTESTS + +As I work on a particular part of my module it's most likely that +the tests that cover that code will fail. I'd like to run the whole +test suite but have it prioritize these 'hot' tests. I can tell +prove to do this: + + prove -rb --state=hot,save t + +All the tests will run but those that failed most recently will be +run first. If no tests have failed since I started saving state all +tests will run in their normal order. This combines full test +coverage with early notification of failures. + +The --state switch supports a number of options; for example to run +failed tests first followed by all remaining tests ordered by the +timestamps of the test scripts - and save the results - I can use + + prove -rb --state=failed,new,save t + +See the prove documentation (type prove --man) for the full list +of state options. + +When I tell prove to save state it writes a file called '.prove' +('_prove' on Windows) in the current directory. It's a YAML document +so it's quite easy to write tools of your own that work on the saved +test state - but the format isn't officially documented so it might +change without (much) warning in the future. + +=head2 Parallel Testing + +If my tests take too long to run I may be able to speed them up by +running multiple test scripts in parallel. This is particularly +effective if the tests are I/O bound or if I have multiple CPU +cores. I tell prove to run my tests in parallel like this: + + prove -rb -j 9 t + +The -j switch enables parallel testing; the number that follows it +is the maximum number of tests to run in parallel. Sometimes tests +that pass when run sequentially will fail when run in parallel. For +example if two different test scripts use the same temporary file +or attempt to listen on the same socket I'll have problems running +them in parallel. If I see unexpected failures I need to check my +tests to work out which of them are trampling on the same resource +and rename temporary files or add locks as appropriate. + +To get the most performance benefit I want to have the test scripts +that take the longest to run start first - otherwise I'll be waiting +for the one test that takes nearly a minute to complete after all +the others are done. I can use the --state switch to run the tests +in slowest to fastest order: + + prove -rb -j 9 --state=slow,save t + +=head2 Non-Perl Tests + +The Test Anything Protocol (http://testanything.org/) isn't just +for Perl. Just about any language can be used to write tests that +output TAP. There are TAP based testing libraries for C, C++, PHP, +Python and many others. If I can't find a TAP library for my language +of choice it's easy to generate valid TAP. It looks like this: + + 1..3 + ok 1 - init OK + ok 2 - opened file + not ok 3 - appended to file + +The first line is the plan - it specifies the number of tests I'm +going to run so that it's easy to check that the test script didn't +exit before running all the expected tests. The following lines are +the test results - 'ok' for pass, 'not ok' for fail. Each test has +a number and, optionally, a description. And that's it. Any language +that can produce output like that on STDOUT can be used to write +tests. + +Recently I've been rekindling a two-decades-old interest in Forth. +Evidently I have a masochistic streak that even Perl can't satisfy. +I want to write tests in Forth and run them using prove (you can +find my gforth TAP experiments at +https://svn.hexten.net/andy/Forth/Testing/). I can use the --exec +switch to tell prove to run the tests using gforth like this: + + prove -r --exec gforth t + +Alternately, if the language used to write my tests allows a shebang +line I can use that to specify the interpreter. Here's a test written +in PHP: + + #!/usr/bin/php + <?php + print "1..2\n"; + print "ok 1\n"; + print "not ok 2\n"; + ?> + +If I save that as t/phptest.t the shebang line will ensure that it +runs correctly along with all my other tests. + +=head2 Mixing it up + +Subtle interdependencies between test programs can mask problems - +for example an earlier test may neglect to remove a temporary file +that affects the behaviour of a later test. To find this kind of +problem I use the --shuffle and --reverse options to run my tests +in random or reversed order. + +=head2 Rolling My Own + +If I need a feature that prove doesn't provide I can easily write my own. + +Typically you'll want to change how TAP gets I<input> into and I<output> +from the parser. L<App::Prove> supports arbitrary plugins, and L<TAP::Harness> +supports custom I<formatters> and I<source handlers> that you can load using +either L<prove> or L<Module::Build>; there are many examples to base mine on. +For more details see L<App::Prove>, L<TAP::Parser::SourceHandler>, and +L<TAP::Formatter::Base>. + +If writing a plugin is not enough, you can write your own test harness; one of +the motives for the 3.00 rewrite of Test::Harness was to make it easier to +subclass and extend. + +The Test::Harness module is a compatibility wrapper around TAP::Harness. +For new applications I should use TAP::Harness directly. As we'll +see, prove uses TAP::Harness. + +When I run prove it processes its arguments, figures out which test +scripts to run and then passes control to TAP::Harness to run the +tests, parse, analyse and present the results. By subclassing +TAP::Harness I can customise many aspects of the test run. + +I want to log my test results in a database so I can track them +over time. To do this I override the summary method in TAP::Harness. +I start with a simple prototype that dumps the results as a YAML +document: + + package My::TAP::Harness; + + use base qw( TAP::Harness ); use YAML; + + sub summary { + my ( $self, $aggregate ) = @_; print Dump( $aggregate ); + $self->SUPER::summary( $aggregate ); + } + + 1; + +I need to tell prove to use my My::TAP::Harness. If My::TAP::Harness +is on Perl's @INC include path I can + + prove --harness=My::TAP::Harness -rb t + +If I don't have My::TAP::Harness installed on @INC I need to provide +the correct path to perl when I run prove: + + perl -Ilib `which prove` --harness=My::TAP::Harness -rb t + +I can incorporate these options into my own version of prove. It's +pretty simple. Most of the work of prove is handled by App::Prove. +The important code in prove is just: + + use App::Prove; + + my $app = App::Prove->new; + $app->process_args(@ARGV); + exit( $app->run ? 0 : 1 ); + +If I write a subclass of App::Prove I can customise any aspect of +the test runner while inheriting all of prove's behaviour. Here's +myprove: + + #!/usr/bin/env perl use lib qw( lib ); # Add ./lib to @INC + use App::Prove; + + my $app = App::Prove->new; + + # Use custom TAP::Harness subclass $app->harness( 'My::TAP::Harness' + ); + + $app->process_args( @ARGV ); exit( $app->run ? 0 : 1 ); + +Now I can run my tests like this + + ./myprove -rb t + +=head2 Deeper Customisation + +Now that I know how to subclass and replace TAP::Harness I can +replace any other part of the harness. To do that I need to know +which classes are responsible for which functionality. Here's a +brief guided tour; the default class for each component is shown +in parentheses. Normally any replacements I write will be subclasses +of these default classes. + +When I run my tests TAP::Harness creates a scheduler +(TAP::Parser::Scheduler) to work out the running order for the +tests, an aggregator (TAP::Parser::Aggregator) to collect and analyse +the test results and a formatter (TAP::Formatter::Console) to display +those results. + +If I'm running my tests in parallel there may also be a multiplexer +(TAP::Parser::Multiplexer) - the component that allows multiple +tests to run simultaneously. + +Once it has created those helpers TAP::Harness starts running the +tests. For each test it creates a new parser (TAP::Parser) which +is responsible for running the test script and parsing its output. + +To replace any of these components I call one of these harness +methods with the name of the replacement class: + + aggregator_class + formatter_class + multiplexer_class + parser_class + scheduler_class + +For example, to replace the aggregator I would + + $harness->aggregator_class( 'My::Aggregator' ); + +Alternately I can supply the names of my substitute classes to the +TAP::Harness constructor: + + my $harness = TAP::Harness->new( + { aggregator_class => 'My::Aggregator' } + ); + +If I need to reach even deeper into the internals of the harness I +can replace the classes that TAP::Parser uses to execute test scripts +and tokenise their output. Before running a test script TAP::Parser +creates a grammar (TAP::Parser::Grammar) to decode the raw TAP into +tokens, a result factory (TAP::Parser::ResultFactory) to turn the +decoded TAP results into objects and, depending on whether it's +running a test script or reading TAP from a file, scalar or array +a source or an iterator (TAP::Parser::IteratorFactory). + +Each of these objects may be replaced by calling one of these parser +methods: + + source_class + perl_source_class + grammar_class + iterator_factory_class + result_factory_class + +=head2 Callbacks + +As an alternative to subclassing the components I need to change I +can attach callbacks to the default classes. TAP::Harness exposes +these callbacks: + + parser_args Tweak the parameters used to create the parser + made_parser Just made a new parser + before_runtests About to run tests + after_runtests Have run all tests + after_test Have run an individual test script + +TAP::Parser also supports callbacks; bailout, comment, plan, test, +unknown, version and yaml are called for the corresponding TAP +result types, ALL is called for all results, ELSE is called for all +results for which a named callback is not installed and EOF is +called once at the end of each TAP stream. + +To install a callback I pass the name of the callback and a subroutine +reference to TAP::Harness or TAP::Parser's callback method: + + $harness->callback( after_test => sub { + my ( $script, $desc, $parser ) = @_; + } ); + +I can also pass callbacks to the constructor: + + my $harness = TAP::Harness->new({ + callbacks => { + after_test => sub { + my ( $script, $desc, $parser ) = @_; + # Do something interesting here + } + } + }); + +When it comes to altering the behaviour of the test harness there's +more than one way to do it. Which way is best depends on my +requirements. In general if I only want to observe test execution +without changing the harness' behaviour (for example to log test +results to a database) I choose callbacks. If I want to make the +harness behave differently subclassing gives me more control. + +=head2 Parsing TAP + +Perhaps I don't need a complete test harness. If I already have a +TAP test log that I need to parse all I need is TAP::Parser and the +various classes it depends upon. Here's the code I need to run a +test and parse its TAP output + + use TAP::Parser; + + my $parser = TAP::Parser->new( { source => 't/simple.t' } ); + while ( my $result = $parser->next ) { + print $result->as_string, "\n"; + } + +Alternately I can pass an open filehandle as source and have the +parser read from that rather than attempting to run a test script: + + open my $tap, '<', 'tests.tap' + or die "Can't read TAP transcript ($!)\n"; + my $parser = TAP::Parser->new( { source => $tap } ); + while ( my $result = $parser->next ) { + print $result->as_string, "\n"; + } + +This approach is useful if I need to convert my TAP based test +results into some other representation. See TAP::Convert::TET +(http://search.cpan.org/dist/TAP-Convert-TET/) for an example of +this approach. + +=head2 Getting Support + +The Test::Harness developers hang out on the tapx-dev mailing +list[1]. For discussion of general, language independent TAP issues +there's the tap-l[2] list. Finally there's a wiki dedicated to the +Test Anything Protocol[3]. Contributions to the wiki, patches and +suggestions are all welcome. + +[1] L<http://www.hexten.net/mailman/listinfo/tapx-dev> +[2] L<http://testanything.org/mailman/listinfo/tap-l> +[3] L<http://testanything.org/> diff --git a/cpan/Test-Harness/lib/TAP/Object.pm b/cpan/Test-Harness/lib/TAP/Object.pm index 498bb805c9..591e435510 100644 --- a/cpan/Test-Harness/lib/TAP/Object.pm +++ b/cpan/Test-Harness/lib/TAP/Object.pm @@ -9,11 +9,11 @@ TAP::Object - Base class that provides common functionality to all C<TAP::*> mod =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS @@ -93,6 +93,25 @@ sub _croak { return; } +=head3 C<_confess> + +Raise an exception using C<confess> from L<Carp>, eg: + + $self->_confess( 'why me?', 'aaarrgh!' ); + +May also be called as a I<class> method. + + $class->_confess( 'this works too' ); + +=cut + +sub _confess { + my $proto = shift; + require Carp; + Carp::confess(@_); + return; +} + =head3 C<_construct> Create a new instance of the specified class. @@ -124,7 +143,7 @@ Create simple getter/setters. sub mk_methods { my ( $class, @methods ) = @_; - foreach my $method_name (@methods) { + for my $method_name (@methods) { my $method = "${class}::$method_name"; no strict 'refs'; *$method = sub { diff --git a/cpan/Test-Harness/lib/TAP/Parser.pm b/cpan/Test-Harness/lib/TAP/Parser.pm index ea3acd907f..92cefb75a1 100644 --- a/cpan/Test-Harness/lib/TAP/Parser.pm +++ b/cpan/Test-Harness/lib/TAP/Parser.pm @@ -3,14 +3,18 @@ package TAP::Parser; use strict; use vars qw($VERSION @ISA); -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 TAP::Base (); +use TAP::Parser::Grammar (); +use TAP::Parser::Result (); +use TAP::Parser::ResultFactory (); +use TAP::Parser::Source (); +use TAP::Parser::Iterator (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::SourceHandler::Executable (); +use TAP::Parser::SourceHandler::Perl (); +use TAP::Parser::SourceHandler::File (); +use TAP::Parser::SourceHandler::RawTAP (); +use TAP::Parser::SourceHandler::Handle (); use Carp qw( confess ); @@ -20,11 +24,11 @@ TAP::Parser - Parse L<TAP|Test::Harness::TAP> output =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; my $DEFAULT_TAP_VERSION = 12; my $MAX_TAP_VERSION = 13; @@ -42,7 +46,7 @@ BEGIN { # making accessors __PACKAGE__->mk_methods( qw( - _stream + _iterator _spool exec exit @@ -56,13 +60,16 @@ BEGIN { # making accessors start_time end_time skip_all - source_class - perl_source_class grammar_class - iterator_factory_class result_factory_class + iterator_factory_class ) ); + + sub _stream { # deprecated + my $self = shift; + $self->_iterator(@_); + } } # done making accessors =head1 SYNOPSIS @@ -105,39 +112,55 @@ The arguments should be a hashref with I<one> of the following keys: =item * C<source> -This is the preferred method of passing arguments to the constructor. To -determine how to handle the source, the following steps are taken. +I<CHANGED in 3.18> -If the source contains a newline, it's assumed to be a string of raw TAP -output. +This is the preferred method of passing input to the constructor. -If the source is a reference, it's assumed to be something to pass to -the L<TAP::Parser::Iterator::Stream> constructor. This is used -internally and you should not use it. +The C<source> is used to create a L<TAP::Parser::Source> that is passed to the +L</iterator_factory_class> which in turn figures out how to handle the source and +creates a <TAP::Parser::Iterator> for it. The iterator is used by the parser to +read in the TAP stream. -Otherwise, the parser does a C<-e> check to see if the source exists. If so, -it attempts to execute the source and read the output as a stream. This is by -far the preferred method of using the parser. +To configure the I<IteratorFactory> use the C<sources> parameter below. - foreach my $file ( @test_files ) { - my $parser = TAP::Parser->new( { source => $file } ); - # do stuff with the parser - } +Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>. =item * C<tap> +I<CHANGED in 3.18> + The value should be the complete TAP output. +The I<tap> is used to create a L<TAP::Parser::Source> that is passed to the +L</iterator_factory_class> which in turn figures out how to handle the source and +creates a <TAP::Parser::Iterator> for it. The iterator is used by the parser to +read in the TAP stream. + +To configure the I<IteratorFactory> use the C<sources> parameter below. + +Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>. + =item * C<exec> -If passed an array reference, will attempt to create the iterator by -passing a L<TAP::Parser::Source> object to -L<TAP::Parser::Iterator::Source>, using the array reference strings as -the command arguments to L<IPC::Open3::open3|IPC::Open3>: +Must be passed an array reference. + +The I<exec> array ref is used to create a L<TAP::Parser::Source> that is passed +to the L</iterator_factory_class> which in turn figures out how to handle the +source and creates a <TAP::Parser::Iterator> for it. The iterator is used by +the parser to read in the TAP stream. + +By default the L<TAP::Parser::SourceHandler::Executable> class will create a +L<TAP::Parser::Iterator::Process> object to handle the source. This passes the +array reference strings as command arguments to L<IPC::Open3::open3|IPC::Open3>: exec => [ '/usr/bin/ruby', 't/my_test.rb' ] -Note that C<source> and C<exec> are mutually exclusive. +If any C<test_args> are given they will be appended to the end of the command +argument list. + +To configure the I<IteratorFactory> use the C<sources> parameter below. + +Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>. =back @@ -145,6 +168,34 @@ The following keys are optional. =over 4 +=item * C<sources> + +I<NEW to 3.18>. + +If set, C<sources> must be a hashref containing the names of the +L<TAP::Parser::SourceHandler>s to load and/or configure. The values are a +hash of configuration that will be accessible to to the source handlers via +L<TAP::Parser::Source/config_for>. + +For example: + + sources => { + Perl => { exec => '/path/to/custom/perl' }, + File => { extensions => [ '.tap', '.txt' ] }, + MyCustom => { some => 'config' }, + } + +This will cause C<TAP::Parser> to pass custom configuration to two of the built- +in source handlers - L<TAP::Parser::SourceHandler::Perl>, +L<TAP::Parser::SourceHandler::File> - and attempt to load the C<MyCustom> +class. See L<TAP::Parser::IteratorFactory/load_handlers> for more detail. + +The C<sources> parameter affects how C<source>, C<tap> and C<exec> parameters +are handled. + +See L<TAP::Parser::IteratorFactory>, L<TAP::Parser::SourceHandler> and subclasses for +more details. + =item * C<callback> If present, each callback corresponding to a given result type will be called @@ -159,7 +210,7 @@ with the result as the argument if the C<run> method is used: ); my $aggregator = TAP::Parser::Aggregator->new; - foreach my $file ( @test_files ) { + for my $file ( @test_files ) { my $parser = TAP::Parser->new( { source => $file, @@ -177,13 +228,13 @@ be used when invoking the perl executable. my $parser = TAP::Parser->new( { source => $test_file, - switches => '-Ilib', + switches => [ '-Ilib' ], } ); =item * C<test_args> -Used in conjunction with the C<source> option to supply a reference to -an C<@ARGV> style array of arguments to pass to the test program. +Used in conjunction with the C<source> and C<exec> option to supply a reference +to an C<@ARGV> style array of arguments to pass to the test program. =item * C<spool> @@ -201,20 +252,6 @@ 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 @@ -222,14 +259,6 @@ 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> @@ -238,6 +267,14 @@ L<TAP::Parser::ResultFactory>. See also L</make_result>. +=item * C<iterator_factory_class> + +I<CHANGED in 3.18> + +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>. + =back =cut @@ -245,11 +282,9 @@ See also L</make_result>. # 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'} +sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'} ############################################################################## @@ -297,20 +332,6 @@ 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 @@ -318,14 +339,6 @@ 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 @@ -334,28 +347,21 @@ given. The C<result_factory_class> can be customized, as described in L</new>. +=head3 C<make_iterator_factory> + +I<NEW to 3.18>. + +Make a new L<TAP::Parser::IteratorFactory> object and return it. Passes through +any arguments given. + +C<iterator_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); - } -} +sub make_iterator_factory { shift->iterator_factory_class->new(@_); } +sub make_grammar { shift->grammar_class->new(@_); } +sub make_result { shift->result_factory_class->make_result(@_); } { @@ -393,18 +399,16 @@ sub _iterator_for_source { ); my @class_overrides = qw( - source_class - perl_source_class grammar_class - iterator_factory_class result_factory_class + iterator_factory_class ); sub _initialize { my ( $self, $arg_for ) = @_; # everything here is basically designed to convert any TAP source to a - # stream. + # TAP::Parser::Iterator. # Shallow copy my %args = %{ $arg_for || {} }; @@ -418,19 +422,21 @@ sub _iterator_for_source { $self->$key($val); } - my $stream = delete $args{stream}; + my $iterator = delete $args{iterator}; + $iterator ||= delete $args{stream}; # deprecated my $tap = delete $args{tap}; - my $source = delete $args{source}; + my $raw_source = delete $args{source}; + my $sources = delete $args{sources}; 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} || [] }; + my $test_args = delete $args{test_args} || []; - if ( 1 < grep {defined} $stream, $tap, $source, $exec ) { + if ( 1 < grep {defined} $iterator, $tap, $raw_source, $exec ) { $self->_croak( - "You may only choose one of 'exec', 'stream', 'tap' or 'source'" + "You may only choose one of 'exec', 'tap', 'source' or 'iterator'" ); } @@ -438,47 +444,42 @@ sub _iterator_for_source { $self->_croak("Unknown options: @excess"); } + # convert $tap & $exec to $raw_source equiv. + my $type = ''; + my $source = TAP::Parser::Source->new; if ($tap) { - $stream = $self->_iterator_for_source( [ split "\n" => $tap ] ); + $type = 'raw TAP'; + $source->raw( \$tap ); } elsif ($exec) { - my $source = $self->make_source; - $source->source( [ @$exec, @test_args ] ); - $source->merge($merge); # XXX should just be arguments? - $stream = $source->get_stream($self); + $type = 'exec ' . $exec->[0]; + $source->raw( { exec => [ @$exec, @$test_args ] } ); + } + elsif ($raw_source) { + $type = 'source ' . ref($raw_source) || $raw_source; + $source->raw( ref($raw_source) ? $raw_source : \$raw_source ); + } + elsif ($iterator) { + $type = 'iterator ' . ref($iterator); } - elsif ($source) { - if ( $source =~ /\n/ ) { - $stream - = $self->_iterator_for_source( [ split "\n" => $source ] ); - } - elsif ( ref $source ) { - $stream = $self->_iterator_for_source($source); - } - elsif ( -e $source ) { - 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($self); - } - else { - $self->_croak("Cannot determine source for $source"); - } + if ( $source->raw ) { + my $src_factory = $self->make_iterator_factory($sources); + $source->merge($merge)->switches($switches) + ->test_args($test_args); + $iterator = $src_factory->make_iterator($source); } - unless ($stream) { - $self->_croak('PANIC: could not determine stream'); + unless ($iterator) { + $self->_croak( + "PANIC: could not determine iterator for input $type"); } while ( my ( $k, $v ) = each %initialize ) { $self->{$k} = 'ARRAY' eq ref $v ? [] : $v; } - $self->_stream($stream); + $self->_iterator($iterator); $self->_spool($spool); $self->ignore_exit($ignore_exit); @@ -1341,23 +1342,23 @@ determine the readiness of this parser. =cut -sub get_select_handles { shift->_stream->get_select_handles } +sub get_select_handles { shift->_iterator->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 + { iterator => $self->_iterator, + parser => $self, + version => $self->version } ); } sub _iter { my $self = shift; - my $stream = $self->_stream; + my $iterator = $self->_iterator; my $grammar = $self->_grammar; my $spool = $self->_spool; my $state = 'INIT'; @@ -1394,8 +1395,8 @@ sub _iter { # Handle end of stream - which means either pop a block or finish my $end_handler = sub { - $self->exit( $stream->exit ); - $self->wait( $stream->wait ); + $self->exit( $iterator->exit ); + $self->wait( $iterator->wait ); $self->_finish; return; }; @@ -1458,7 +1459,7 @@ sub _finish { $self->end_time( $self->get_time ); # Avoid leaks - $self->_stream(undef); + $self->_iterator(undef); $self->_grammar(undef); # If we just delete the iter we won't get a fault if it's recreated. @@ -1532,7 +1533,7 @@ result as its argument. ); my $aggregator = TAP::Parser::Aggregator->new; - foreach my $file ( @test_files ) { + for my $file ( @test_files ) { my $parser = TAP::Parser->new( { source => $file, @@ -1685,7 +1686,7 @@ never run. They're reported as parse failures (tests out of sequence). 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. +designed to be easily plugged-into and/or subclassed. Before you start, it's important to know a few things: @@ -1697,17 +1698,20 @@ All C<TAP::*> objects inherit from L<TAP::Object>. =item 2 -Most C<TAP::*> classes have a I<SUBCLASSING> section to guide you. +Many 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. +responsible for creating most 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. +The exception to this rule are I<SourceHandlers> & I<Iterators>, but those are +both created with customizeable I<IteratorFactory>. + =item 4 By subclassing, you may end up overriding undocumented methods. That's not @@ -1722,28 +1726,41 @@ deprecated first, and changed in a later release. =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. +A TAP parser consumes input from a single I<raw source> of TAP, which could come +from anywhere (a file, an executable, a database, an io handle, a uri, etc..). +The source gets bundled up in a L<TAP::Parser::Source> object which gathers some +meta data about it. The parser then uses a L<TAP::Parser::IteratorFactory> to +determine which L<TAP::Parser::SourceHandler> to use to turn the raw source +into a stream of TAP by way of L</Iterators>. -If you need to customize the objects on creation, subclass L<TAP::Parser> and -override L</make_source> or L</make_perl_source>. +If you simply want C<TAP::Parser> to handle a new source of TAP you probably +don't need to subclass C<TAP::Parser> itself. Rather, you'll need to create a +new L<TAP::Parser::SourceHandler> class, and just plug it into the parser using +the I<sources> param to L</new>. Before you start writing one, read through +L<TAP::Parser::IteratorFactory> to get a feel for how the system works first. + +If you find you really need to use your own iterator factory you can still do +so without sub-classing C<TAP::Parser> by setting L</iterator_factory_class>. + +If you just need to customize the objects on creation, subclass L<TAP::Parser> +and override L</make_iterator_factory>. + +Note that L</make_source> & L</make_perl_source> have been I<DEPRECATED> and +are now removed. =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>. +A TAP parser uses I<iterators> to loop through the I<stream> of TAP read in +from the I<source> it was given. There are a few types of Iterators available +by default, all sub-classes of L<TAP::Parser::Iterator>. Choosing which +iterator to use is the responsibility of the I<siterator factory>, though it +simply delegates to the I<Source Handler> it uses. -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're writing your own L<TAP::Parser::SourceHandler>, you may need to +create your own iterators too. If so you'll need to subclass +L<TAP::Parser::Iterator>. -If you need to customize the objects on creation, subclass L<TAP::Parser> and -override L</make_iterator>. +Note that L</make_iterator> has been I<DEPRECATED> and is now removed. =head3 Results @@ -1830,6 +1847,8 @@ support, or just words of encouragement have all been forthcoming. =item * Alex Vandiver +=item * Cosimo Streppone + =back =head1 AUTHORS @@ -1848,6 +1867,8 @@ Steve Purkis <spurkis@cpan.org> Nicholas Clark <nick@ccl4.org> +Lee Johnson <notfadeaway at btinternet dot com> + =head1 BUGS Please report any bugs or feature requests to @@ -1859,7 +1880,7 @@ progress on your bug as we make changes. Obviously, bugs which include patches are best. If you prefer, you can patch against bleed by via anonymous checkout of the latest version: - svn checkout http://svn.hexten.net/tapx + git clone git://github.com/AndyA/Test-Harness.git =head1 COPYRIGHT & LICENSE diff --git a/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm b/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm index 10b37ef72a..931656fdc9 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm @@ -14,11 +14,11 @@ TAP::Parser::Aggregator - Aggregate TAP::Parser results =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS @@ -74,7 +74,7 @@ BEGIN { # install summary methods $SUMMARY_METHOD_FOR{total} = 'tests_run'; $SUMMARY_METHOD_FOR{planned} = 'tests_planned'; - foreach my $method ( keys %SUMMARY_METHOD_FOR ) { + for my $method ( keys %SUMMARY_METHOD_FOR ) { next if 'total' eq $method; no strict 'refs'; *$method = sub { @@ -90,7 +90,7 @@ sub _initialize { my ($self) = @_; $self->{parser_for} = {}; $self->{parse_order} = []; - foreach my $summary ( keys %SUMMARY_METHOD_FOR ) { + for my $summary ( keys %SUMMARY_METHOD_FOR ) { $self->{$summary} = 0; next if 'total' eq $summary; $self->{"descriptions_for_$summary"} = []; @@ -175,7 +175,7 @@ sub parsers { sub _get_parsers { my ( $self, @descriptions ) = @_; my @parsers; - foreach my $description (@descriptions) { + for my $description (@descriptions) { $self->_croak("A parser for ($description) could not be found") unless exists $self->{parser_for}{$description}; push @parsers => $self->{parser_for}{$description}; diff --git a/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm b/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm index 44f28a0491..7847098c5c 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm @@ -15,27 +15,27 @@ TAP::Parser::Grammar - A grammar for the Test Anything Protocol. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS use TAP::Parser::Grammar; my $grammar = $self->make_grammar({ - stream => $tap_parser_stream, - parser => $tap_parser, - version => 12, + iterator => $tap_parser_iterator, + parser => $tap_parser, + version => 12, }); my $result = $grammar->tokenize; =head1 DESCRIPTION -C<TAP::Parser::Grammar> tokenizes lines from a TAP stream and constructs -L<TAP::Parser::Result> subclasses to represent the tokens. +C<TAP::Parser::Grammar> tokenizes lines from a L<TAP::Parser::Iterator> and +constructs L<TAP::Parser::Result> subclasses to represent the tokens. Do not attempt to use this class directly. It won't make sense. It's mainly here to ensure that we will be able to have pluggable grammars when TAP is @@ -49,22 +49,24 @@ parser). =head3 C<new> my $grammar = TAP::Parser::Grammar->new({ - stream => $stream, - parser => $parser, - version => $version, + iterator => $iterator, + parser => $parser, + version => $version, }); -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). +Returns L<TAP::Parser> grammar object that will parse the TAP stream from the +specified iterator. Both C<iterator> 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 # new() implementation supplied by TAP::Object sub _initialize { my ( $self, $args ) = @_; - $self->{stream} = $args->{stream}; # TODO: accessor - $self->{parser} = $args->{parser}; # TODO: accessor + $self->{iterator} = $args->{iterator}; # TODO: accessor + $self->{iterator} ||= $args->{stream}; # deprecated + $self->{parser} = $args->{parser}; # TODO: accessor $self->set_version( $args->{version} || 12 ); return $self; } @@ -218,7 +220,7 @@ my %language_for; '13' => { tokens => \%v13, setup => sub { - shift->{stream}->handle_unicode; + shift->{iterator}->handle_unicode; }, }, ); @@ -284,7 +286,7 @@ current line of TAP. sub tokenize { my $self = shift; - my $line = $self->{stream}->next; + my $line = $self->{iterator}->next; unless ( defined $line ) { delete $self->{parser}; # break circular ref return; @@ -292,7 +294,7 @@ sub tokenize { my $token; - foreach my $token_data ( @{ $self->{ordered_tokens} } ) { + for my $token_data ( @{ $self->{ordered_tokens} } ) { if ( $line =~ $token_data->{syntax} ) { my $handler = $token_data->{handler}; $token = $self->$handler($line); @@ -351,7 +353,7 @@ TAP parsing loop looks similar to the following: my @tokens; my $grammar = TAP::Grammar->new; LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) { - foreach my $type ( $grammar->token_types ) { + for my $type ( $grammar->token_types ) { my $syntax = $grammar->syntax_for($type); if ( $line =~ $syntax ) { my $handler = $grammar->handler_for($type); @@ -443,7 +445,7 @@ sub _make_yaml_token { my $yaml = TAP::Parser::YAMLish::Reader->new; - my $stream = $self->{stream}; + my $iterator = $self->{iterator}; # Construct a reader that reads from our input stripping leading # spaces from each line. @@ -452,7 +454,7 @@ sub _make_yaml_token { my @extra = ($marker); my $reader = sub { return shift @extra if @extra; - my $line = $stream->next; + my $line = $iterator->next; return $2 if $line =~ $strip; return; }; diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm index 09d40bebcc..a6d8916751 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm @@ -9,20 +9,18 @@ use TAP::Object (); =head1 NAME -TAP::Parser::Iterator - Internal base class for TAP::Parser Iterators +TAP::Parser::Iterator - Base class for TAP source iterators =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS - # see TAP::Parser::IteratorFactory for general usage - # to subclass: use vars qw(@ISA); use TAP::Parser::Iterator (); @@ -31,11 +29,14 @@ $VERSION = '3.17'; # see TAP::Object... } + sub next_raw { ... } + sub wait { ... } + sub exit { ... } + =head1 DESCRIPTION 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. +API. Iterators are typically created from L<TAP::Parser::SourceHandler>s. =head1 METHODS @@ -156,7 +157,6 @@ There's not much point repeating it here. 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>, diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm index 1513d5b994..99d98ca172 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm @@ -9,21 +9,18 @@ use TAP::Parser::Iterator (); =head1 NAME -TAP::Parser::Iterator::Array - Internal TAP::Parser array Iterator +TAP::Parser::Iterator::Array - Iterator for array-based TAP sources =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS - # 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); @@ -32,8 +29,8 @@ $VERSION = '3.17'; =head1 DESCRIPTION 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. +L<TAP::Parser>. Unless you're writing a plugin or subclassing, you probably +won't need to use this module directly. =head1 METHODS @@ -100,7 +97,6 @@ Originally ripped off from L<Test::Harness>. L<TAP::Object>, L<TAP::Parser>, L<TAP::Parser::Iterator>, -L<TAP::Parser::IteratorFactory>, =cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm index a0a5a8ed32..2621e75ef2 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm @@ -13,21 +13,18 @@ my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ ); =head1 NAME -TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator +TAP::Parser::Iterator::Process - Iterator for proccess-based TAP sources =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS - # see TAP::Parser::IteratorFactory for preferred usage - - # to use directly: use TAP::Parser::Iterator::Process; my %args = ( command => ['python', 'setup.py', 'test'], @@ -41,8 +38,8 @@ $VERSION = '3.17'; =head1 DESCRIPTION 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. +L<TAP::Parser>. Unless you're writing a plugin or subclassing, you probably +won't need to use this module directly. =head1 METHODS @@ -80,12 +77,18 @@ Get the exit status for this iterator's process. =cut -eval { require POSIX; &POSIX::WEXITSTATUS(0) }; -if ($@) { - *_wait2exit = sub { $_[1] >> 8 }; -} -else { - *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) } +{ + + local $^W; # no warnings + # get around a catch22 in the test suite that causes failures on Win32: + local $SIG{__DIE__} = undef; + eval { require POSIX; &POSIX::WEXITSTATUS(0) }; + if ($@) { + *_wait2exit = sub { $_[1] >> 8 }; + } + else { + *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) } + } } sub _use_open3 { @@ -117,6 +120,8 @@ sub _initialize { my @command = @{ delete $args->{command} || [] } or die "Must supply a command to execute"; + $self->{command} = [@command]; + # Private. Used to frig with chunk size during testing. my $chunk_size = delete $args->{_chunk_size} || 65536; @@ -371,7 +376,6 @@ Originally ripped off from L<Test::Harness>. L<TAP::Object>, L<TAP::Parser>, L<TAP::Parser::Iterator>, -L<TAP::Parser::IteratorFactory>, =cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm index c92cbabe08..d905695859 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm @@ -9,21 +9,18 @@ use TAP::Parser::Iterator (); =head1 NAME -TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator +TAP::Parser::Iterator::Stream - Iterator for filehandle-based TAP sources =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS - # 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); @@ -32,8 +29,8 @@ $VERSION = '3.17'; =head1 DESCRIPTION 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. +L<TAP::Parser>. Unless you're writing a plugin or subclassing, you probably +won't need to use this module directly. =head1 METHODS @@ -106,7 +103,6 @@ Originally ripped off from L<Test::Harness>. L<TAP::Object>, L<TAP::Parser>, L<TAP::Parser::Iterator>, -L<TAP::Parser::IteratorFactory>, =cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm b/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm index 064d7beb16..b269d000b9 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm @@ -3,40 +3,40 @@ 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 (); +use TAP::Object (); + +use Carp qw( confess ); +use File::Basename qw( fileparse ); @ISA = qw(TAP::Object); +use constant handlers => []; + =head1 NAME -TAP::Parser::IteratorFactory - Internal TAP::Parser Iterator +TAP::Parser::IteratorFactory - Figures out which SourceHandler objects to use for a given Source =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =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; + my $factory = TAP::Parser::IteratorFactory->new({ %config }); + my $iterator = $factory->make_iterator( $filename ); =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. +This is a factory class that takes a L<TAP::Parser::Source> and runs it through all the +registered L<TAP::Parser::SourceHandler>s to see which one should handle the source. + +If you're a plugin author, you'll be interested in how to L</register_handler>s, +how L</detect_source> works. =head1 METHODS @@ -44,128 +44,299 @@ module directly. =head3 C<new> -Creates a new factory class. -I<Note:> You currently don't need to instantiate a factory in order to use it. +Creates a new factory class: -=head3 C<make_iterator> + my $sf = TAP::Parser::IteratorFactory->new( $config ); -Create an iterator. The type of iterator created depends on the arguments to -the constructor: +C<$config> is optional. If given, sets L</config> and calls L</load_handlers>. - my $iter = TAP::Parser::Iterator->make_iterator( $filehandle ); +=cut + +sub _initialize { + my ( $self, $config ) = @_; + $self->config( $config || {} )->load_handlers; + return $self; +} -Creates a I<stream> iterator (see L</make_stream_iterator>). +=head3 C<register_handler> - my $iter = TAP::Parser::Iterator->make_iterator( $array_reference ); +Registers a new L<TAP::Parser::SourceHandler> with this factory. -Creates an I<array> iterator (see L</make_array_iterator>). + __PACKAGE__->register_handler( $handler_class ); - my $iter = TAP::Parser::Iterator->make_iterator( $hash_reference ); +=head3 C<handlers> -Creates a I<process> iterator (see L</make_process_iterator>). +List of handlers that have been registered. =cut -sub make_iterator { - my ( $proto, $thing ) = @_; +sub register_handler { + my ( $class, $dclass ) = @_; - 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"; + confess("$dclass must implement can_handle & make_iterator methods!") + unless UNIVERSAL::can( $dclass, 'can_handle' ) + && UNIVERSAL::can( $dclass, 'make_iterator' ); + + my $handlers = $class->handlers; + push @{$handlers}, $dclass + unless grep { $_ eq $dclass } @{$handlers}; + + return $class; +} + +############################################################################## + +=head2 Instance Methods + +=head3 C<config> + + my $cfg = $sf->config; + $sf->config({ Perl => { %config } }); + +Chaining getter/setter for the configuration of the available source handlers. +This is a hashref keyed on handler class whose values contain config to be passed +onto the handlers during detection & creation. Class names may be fully qualified +or abbreviated, eg: + + # these are equivalent + $sf->config({ 'TAP::Parser::SourceHandler::Perl' => { %config } }); + $sf->config({ 'Perl' => { %config } }); + +=cut + +sub config { + my $self = shift; + return $self->{config} unless @_; + unless ( 'HASH' eq ref $_[0] ) { + $self->_croak('Argument to &config must be a hash reference'); } + $self->{config} = shift; + return $self; +} + +sub _last_handler { + my $self = shift; + return $self->{last_handler} unless @_; + $self->{last_handler} = shift; + return $self; +} + +sub _testing { + my $self = shift; + return $self->{testing} unless @_; + $self->{testing} = shift; + return $self; } -=head3 C<make_stream_iterator> +############################################################################## + +=head3 C<load_handlers> + + $sf->load_handlers; -Make a new stream iterator and return it. Passes through any arguments given. -Defaults to a L<TAP::Parser::Iterator::Stream>. +Loads the handler classes defined in L</config>. For example, given a config: -=head3 C<make_array_iterator> + $sf->config({ + MySourceHandler => { some => 'config' }, + }); -Make a new array iterator and return it. Passes through any arguments given. -Defaults to a L<TAP::Parser::Iterator::Array>. +C<load_handlers> will attempt to load the C<MySourceHandler> class by looking in +C<@INC> for it in this order: -=head3 C<make_process_iterator> + TAP::Parser::SourceHandler::MySourceHandler + MySourceHandler -Make a new process iterator and return it. Passes through any arguments given. -Defaults to a L<TAP::Parser::Iterator::Process>. +C<croak>s on error. =cut -sub make_stream_iterator { - my $proto = shift; - TAP::Parser::Iterator::Stream->new(@_); +sub load_handlers { + my ($self) = @_; + for my $handler ( keys %{ $self->config } ) { + my $sclass = $self->_load_handler($handler); + + # TODO: store which class we loaded anywhere? + } + return $self; } -sub make_array_iterator { - my $proto = shift; - TAP::Parser::Iterator::Array->new(@_); +sub _load_handler { + my ( $self, $handler ) = @_; + + my @errors; + for my $dclass ( "TAP::Parser::SourceHandler::$handler", $handler ) { + return $dclass + if UNIVERSAL::can( $dclass, 'can_handle' ) + && UNIVERSAL::can( $dclass, 'make_iterator' ); + + eval "use $dclass"; + if ( my $e = $@ ) { + push @errors, $e; + next; + } + + return $dclass + if UNIVERSAL::can( $dclass, 'can_handle' ) + && UNIVERSAL::can( $dclass, 'make_iterator' ); + push @errors, + "handler '$dclass' does not implement can_handle & make_iterator"; + } + + $self->_croak( + "Cannot load handler '$handler': " . join( "\n", @errors ) ); } -sub make_process_iterator { - my $proto = shift; - TAP::Parser::Iterator::Process->new(@_); +############################################################################## + +=head3 C<make_iterator> + + my $iterator = $src_factory->make_iterator( $source ); + +Given a L<TAP::Parser::Source>, finds the most suitable L<TAP::Parser::SourceHandler> +to use to create a L<TAP::Parser::Iterator> (see L</detect_source>). Dies on error. + +=cut + +sub make_iterator { + my ( $self, $source ) = @_; + + $self->_croak('no raw source defined!') unless defined $source->raw; + + $source->config( $self->config )->assemble_meta; + + # is the raw source already an object? + return $source->raw + if ( $source->meta->{is_object} + && UNIVERSAL::isa( $source->raw, 'TAP::Parser::SourceHandler' ) ); + + # figure out what kind of source it is + my $sd_class = $self->detect_source($source); + $self->_last_handler($sd_class); + + return if $self->_testing; + + # create it + my $iterator = $sd_class->make_iterator($source); + + return $iterator; } -1; +=head3 C<detect_source> -=head1 SUBCLASSING +Given a L<TAP::Parser::Source>, detects what kind of source it is and +returns I<one> L<TAP::Parser::SourceHandler> (the most confident one). Dies +on error. -Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. +The detection algorithm works something like this: + + for (@registered_handlers) { + # ask them how confident they are about handling this source + $confidence{$handler} = $handler->can_handle( $source ) + } + # choose the most confident handler + +Ties are handled by choosing the first handler. + +=cut + +sub detect_source { + my ( $self, $source ) = @_; -There are a few things to bear in mind when creating your own -C<ResultFactory>: + confess('no raw source ref defined!') unless defined $source->raw; -=over 4 + # find a list of handlers that can handle this source: + my %handlers; + for my $dclass ( @{ $self->handlers } ) { + my $confidence = $dclass->can_handle($source); -=item 1 + # warn "handler: $dclass: $confidence\n"; + $handlers{$dclass} = $confidence if $confidence; + } + + if ( !%handlers ) { + + # use Data::Dump qw( pp ); + # warn pp( $meta ); + + # error: can't detect source + my $raw_source_short = substr( ${ $source->raw }, 0, 50 ); + confess("Cannot detect source of '$raw_source_short'!"); + return; + } -The factory itself is never instantiated (this I<may> change in the future). -This means that C<_initialize> is never called. + # if multiple handlers can handle it, choose the most confident one + my @handlers = ( + map {$_} + sort { $handlers{$a} cmp $handlers{$b} } + keys %handlers + ); + + # this is really useful for debugging handlers: + if ( $ENV{TAP_HARNESS_SOURCE_FACTORY_VOTES} ) { + warn( + "votes: ", + join( ', ', map {"$_: $handlers{$_}"} @handlers ), + "\n" + ); + } + + # return 1st + return pop @handlers; +} + +1; -=back +__END__ + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. =head2 Example +If we've done things right, you'll probably want to write a new source, +rather than sub-classing this (see L<TAP::Parser::SourceHandler> for that). + +But in case you find the need to... + 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(@_); + # override source detection algorithm + sub detect_source { + my ($self, $raw_source_ref, $meta) = @_; + # do detective work, using $meta and whatever else... } 1; +=head1 AUTHORS + +Steve Purkis + =head1 ATTRIBUTION Originally ripped off from L<Test::Harness>. +Moved out of L<TAP::Parser> & converted to a factory class to support +extensible TAP source detective work by Steve Purkis. + =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>, +L<TAP::Parser::SourceHandler>, +L<TAP::Parser::SourceHandler::File>, +L<TAP::Parser::SourceHandler::Perl>, +L<TAP::Parser::SourceHandler::RawTAP>, +L<TAP::Parser::SourceHandler::Handle>, +L<TAP::Parser::SourceHandler::Executable> =cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm b/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm index 2e5d929688..9d33619294 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm @@ -18,11 +18,11 @@ TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result.pm b/cpan/Test-Harness/lib/TAP/Parser/Result.pm index b01e95c5d9..44287e89a8 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result.pm @@ -26,11 +26,11 @@ TAP::Parser::Result - Base class for TAP::Parser output objects =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm index 3e42f4110f..8aeecfa29c 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Bailout - Bailout result token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm index 1e9ba13c5f..b5498abd5d 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Comment - Comment result token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm index 67c01df200..78b77c35a1 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Plan - Plan result token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm index 3eb62b3322..bef77fda71 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Pragma - TAP pragma token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm index 11cf302de6..fcae343266 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm @@ -14,11 +14,11 @@ TAP::Parser::Result::Test - Test result token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm index 52e19585d9..b08536e267 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm @@ -14,11 +14,11 @@ TAP::Parser::Result::Unknown - Unknown result token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm index b97681eb06..06d63bf1ae 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Version - TAP syntax version token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm index ada3ae445b..aa7bc4c887 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::YAML - YAML result token. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm b/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm index 46d0df29db..66ee9fb36f 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm @@ -30,11 +30,11 @@ TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head2 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm index f1817093af..c23f1eac64 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm @@ -12,11 +12,11 @@ TAP::Parser::Scheduler - Schedule tests during parallel testing =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS @@ -231,7 +231,7 @@ sub get_job { sub _not_empty { my $ar = shift; return 1 unless 'ARRAY' eq ref $ar; - foreach (@$ar) { + for (@$ar) { return 1 if _not_empty($_); } return; diff --git a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm index 7ab68f9f67..f3a377cc1e 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Job - A single testing job. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm index 10af5e3369..0d43716842 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Spinner - A no-op job. =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Source.pm b/cpan/Test-Harness/lib/TAP/Parser/Source.pm index 9263e9e544..62d3795f02 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Source.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Source.pm @@ -3,35 +3,49 @@ package TAP::Parser::Source; use strict; use vars qw($VERSION @ISA); -use TAP::Object (); -use TAP::Parser::IteratorFactory (); +use TAP::Object (); +use File::Basename qw( fileparse ); @ISA = qw(TAP::Object); -# Causes problem on MacOS and shouldn't be necessary anyway -#$SIG{CHLD} = sub { wait }; - =head1 NAME -TAP::Parser::Source - Stream output from some source +TAP::Parser::Source - a TAP source & meta data about it =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS use TAP::Parser::Source; my $source = TAP::Parser::Source->new; - my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream; + $source->raw( \'reference to raw TAP source' ) + ->config( \%config ) + ->merge( $boolean ) + ->switches( \@switches ) + ->test_args( \@args ) + ->assemble_meta; + + do { ... } if $source->meta->{is_file}; + # see assemble_meta for a full list of data available =head1 DESCRIPTION -Takes a command and hopefully returns a stream from it. +A TAP I<source> is something that produces a stream of TAP for the parser to +consume, such as an executable file, a text file, an archive, an IO handle, a +database, etc. C<TAP::Parser::Source>s encapsulate these I<raw> sources, and +provide some useful meta data about them. They are used by +L<TAP::Parser::SourceHandler>s, which do whatever is required to produce & +capture a stream of TAP from the I<raw> source, and package it up in a +L<TAP::Parser::Iterator> for the parser to consume. + +Unless you're writing a new L<TAP::Parser::SourceHandler>, a plugin or +subclassing L<TAP::Parser>, you probably won't need to use this module directly. =head1 METHODS @@ -48,10 +62,9 @@ Returns a new C<TAP::Parser::Source> object. # new() implementation supplied by TAP::Object sub _initialize { - my ( $self, $args ) = @_; - $self->{switches} = []; - _autoflush( \*STDOUT ); - _autoflush( \*STDERR ); + my ($self) = @_; + $self->meta( {} ); + $self->config( {} ); return $self; } @@ -59,69 +72,86 @@ sub _initialize { =head2 Instance Methods -=head3 C<source> +=head3 C<raw> - my $source = $source->source; - $source->source(['./some_prog some_test_file']); + my $raw = $source->raw; + $source->raw( $some_value ); - # or - $source->source(['/usr/bin/ruby', 't/ruby_test.rb']); +Chaining getter/setter for the raw TAP source. This is a reference, as it may +contain large amounts of data (eg: raw TAP). -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. C<croaks> if -it doesn't get an arrayref. +=head3 C<meta> -=cut + my $meta = $source->meta; + $source->meta({ %some_value }); -sub source { - my $self = shift; - return $self->{source} unless @_; - unless ( 'ARRAY' eq ref $_[0] ) { - $self->_croak('Argument to &source must be an array reference'); - } - $self->{source} = shift; - return $self; -} +Chaining getter/setter for meta data about the source. This defaults to an +empty hashref. See L</assemble_meta> for more info. -############################################################################## +=head3 C<has_meta> -=head3 C<get_stream> +True if the source has meta data. - my $stream = $source->get_stream; +=head3 C<config> -Returns a L<TAP::Parser::Iterator> stream of the output generated by executing -C<source>. C<croak>s if there was no command found. + my $config = $source->config; + $source->config({ %some_value }); -Must be passed an object that implements a C<make_iterator> method. -Typically this is a TAP::Parser instance. +Chaining getter/setter for the source's configuration, if any has been provided +by the user. How it's used is up to you. This defaults to an empty hashref. +See L</config_for> for more info. -=cut +=head3 C<merge> -sub get_stream { - my ( $self, $factory ) = @_; - my @command = $self->_get_command - or $self->_croak('No command found!'); + my $merge = $source->merge; + $source->config( $bool ); - return $factory->make_iterator( - { command => \@command, - merge => $self->merge - } - ); -} +Chaining getter/setter for the flag that dictates whether STDOUT and STDERR +should be merged (where appropriate). Defaults to undef. -sub _get_command { return @{ shift->source || [] } } +=head3 C<switches> -############################################################################## + my $switches = $source->switches; + $source->config([ @switches ]); -=head3 C<merge> +Chaining getter/setter for the list of command-line switches that should be +passed to the source (where appropriate). Defaults to undef. - my $merge = $source->merge; +=head3 C<test_args> + + my $test_args = $source->test_args; + $source->config([ @test_args ]); -Sets or returns the flag that dictates whether STDOUT and STDERR are merged. +Chaining getter/setter for the list of command-line arguments that should be +passed to the source (where appropriate). Defaults to undef. =cut +sub raw { + my $self = shift; + return $self->{raw} unless @_; + $self->{raw} = shift; + return $self; +} + +sub meta { + my $self = shift; + return $self->{meta} unless @_; + $self->{meta} = shift; + return $self; +} + +sub has_meta { + return scalar %{ shift->meta } ? 1 : 0; +} + +sub config { + my $self = shift; + return $self->{config} unless @_; + $self->{config} = shift; + return $self; +} + sub merge { my $self = shift; return $self->{merge} unless @_; @@ -129,45 +159,227 @@ sub merge { return $self; } -# Turns on autoflush for the handle passed -sub _autoflush { - my $flushed = shift; - my $old_fh = select $flushed; - $| = 1; - select $old_fh; +sub switches { + my $self = shift; + return $self->{switches} unless @_; + $self->{switches} = shift; + return $self; } -1; +sub test_args { + my $self = shift; + return $self->{test_args} unless @_; + $self->{test_args} = shift; + return $self; +} + +=head3 C<assemble_meta> + + my $meta = $source->assemble_meta; + +Gathers meta data about the L</raw> source, stashes it in L</meta> and returns +it as a hashref. This is done so that the L<TAP::Parser::SourceHandler>s don't +have to repeat common checks. Currently this includes: + + is_scalar => $bool, + is_hash => $bool, + is_array => $bool, + + # for scalars: + length => $n + has_newlines => $bool + + # only done if the scalar looks like a filename + is_file => $bool, + is_dir => $bool, + is_symlink => $bool, + file => { + # only done if the scalar looks like a filename + basename => $string, # including ext + dir => $string, + ext => $string, + lc_ext => $string, + # system checks + exists => $bool, + stat => [ ... ], # perldoc -f stat + empty => $bool, + size => $n, + text => $bool, + binary => $bool, + read => $bool, + write => $bool, + execute => $bool, + setuid => $bool, + setgid => $bool, + sticky => $bool, + is_file => $bool, + is_dir => $bool, + is_symlink => $bool, + # only done if the file's a symlink + lstat => [ ... ], # perldoc -f lstat + # only done if the file's a readable text file + shebang => $first_line, + } -=head1 SUBCLASSING + # for arrays: + size => $n, -Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. +=cut -=head2 Example +sub assemble_meta { + my ($self) = @_; - package MyRubySource; + return $self->meta if $self->has_meta; - use strict; - use vars '@ISA'; + my $meta = $self->meta; + my $raw = $self->raw; - use Carp qw( croak ); - use TAP::Parser::Source; + # rudimentary is object test - if it's blessed it'll + # inherit from UNIVERSAL + $meta->{is_object} = UNIVERSAL::isa( $raw, 'UNIVERSAL' ) ? 1 : 0; + + if ( $meta->{is_object} ) { + $meta->{class} = ref($raw); + } + else { + my $ref = lc( ref($raw) ); + $meta->{"is_$ref"} = 1; + } + + if ( $meta->{is_scalar} ) { + my $source = $$raw; + $meta->{length} = length($$raw); + $meta->{has_newlines} = $$raw =~ /\n/ ? 1 : 0; + + # only do file checks if it looks like a filename + if ( !$meta->{has_newlines} and $meta->{length} < 1024 ) { + my $file = {}; + $file->{exists} = -e $source ? 1 : 0; + if ( $file->{exists} ) { + $meta->{file} = $file; + + # avoid extra system calls (see `perldoc -f -X`) + $file->{stat} = [ stat(_) ]; + $file->{empty} = -z _ ? 1 : 0; + $file->{size} = -s _; + $file->{text} = -T _ ? 1 : 0; + $file->{binary} = -B _ ? 1 : 0; + $file->{read} = -r _ ? 1 : 0; + $file->{write} = -w _ ? 1 : 0; + $file->{execute} = -x _ ? 1 : 0; + $file->{setuid} = -u _ ? 1 : 0; + $file->{setgid} = -g _ ? 1 : 0; + $file->{sticky} = -k _ ? 1 : 0; + + $meta->{is_file} = $file->{is_file} = -f _ ? 1 : 0; + $meta->{is_dir} = $file->{is_dir} = -d _ ? 1 : 0; + + # symlink check requires another system call + $meta->{is_symlink} = $file->{is_symlink} + = -l $source ? 1 : 0; + if ( $file->{is_symlink} ) { + $file->{lstat} = [ lstat(_) ]; + } + + # put together some common info about the file + ( $file->{basename}, $file->{dir}, $file->{ext} ) + = map { defined $_ ? $_ : '' } + fileparse( $source, qr/\.[^.]*/ ); + $file->{lc_ext} = lc( $file->{ext} ); + $file->{basename} .= $file->{ext} if $file->{ext}; + + if ( $file->{text} and $file->{read} ) { + eval { $file->{shebang} = $self->_read_shebang($$raw); }; + if ( my $e = $@ ) { + warn $e; + } + } + } + } + } + elsif ( $meta->{is_array} ) { + $meta->{size} = $#$raw + 1; + } + elsif ( $meta->{is_hash} ) { + ; # do nothing + } + + return $meta; +} + +=head3 C<shebang> + +Get the shebang line for a script file. + + my $shebang = TAP::Parser::Source->shebang( $some_script ); + +May be called as a class method + +=cut + +{ + + # Global shebang cache. + my %shebang_for; - @ISA = qw( TAP::Parser::Source ); + sub _read_shebang { + my ( $self, $file ) = @_; + my $shebang; + local *TEST; + if ( open( TEST, $file ) ) { + $shebang = <TEST>; + chomp $shebang; + close(TEST) or die "Can't close $file. $!\n"; + } + else { + die "Can't open $file. $!\n"; + } + return $shebang; + } + + sub shebang { + my ( $class, $file ) = @_; + $shebang_for{$file} = $class->_read_shebang($file) + unless exists $shebang_for{$file}; + return $shebang_for{$file}; + } +} + +=head3 C<config_for> + + my $config = $source->config_for( $class ); + +Returns L</config> for the $class given. Class names may be fully qualified +or abbreviated, eg: + + # these are equivalent + $source->config_for( 'Perl' ); + $source->config_for( 'TAP::Parser::SourceHandler::Perl' ); - # 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]); - } +If a fully qualified $class is given, its abbreviated version is checked first. + +=cut + +sub config_for { + my ( $self, $class ) = @_; + my ($abbrv_class) = ( $class =~ /(?:\:\:)?(\w+)$/ ); + my $config = $self->config->{$abbrv_class} || $self->config->{$class}; + return $config; +} + +1; + +__END__ + +=head1 AUTHORS + +Steve Purkis. =head1 SEE ALSO L<TAP::Object>, L<TAP::Parser>, -L<TAP::Parser::Source::Perl>, +L<TAP::Parser::IteratorFactory>, +L<TAP::Parser::SourceHandler> =cut - diff --git a/cpan/Test-Harness/lib/TAP/Parser/Source/Perl.pm b/cpan/Test-Harness/lib/TAP/Parser/Source/Perl.pm deleted file mode 100644 index 1f4f2e1428..0000000000 --- a/cpan/Test-Harness/lib/TAP/Parser/Source/Perl.pm +++ /dev/null @@ -1,326 +0,0 @@ -package TAP::Parser::Source::Perl; - -use strict; -use Config; -use vars qw($VERSION @ISA); - -use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); -use constant IS_VMS => ( $^O eq 'VMS' ); - -use TAP::Parser::Source; -use TAP::Parser::Utils qw( split_shell ); - -@ISA = 'TAP::Parser::Source'; - -=head1 NAME - -TAP::Parser::Source::Perl - Stream Perl output - -=head1 VERSION - -Version 3.17 - -=cut - -$VERSION = '3.17'; - -=head1 SYNOPSIS - - use TAP::Parser::Source::Perl; - my $perl = TAP::Parser::Source::Perl->new; - my $stream = $perl->source( [ $filename, @args ] )->get_stream; - -=head1 DESCRIPTION - -Takes a filename and hopefully returns a stream from it. The filename should -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 METHODS - -=head2 Class Methods - -=head3 C<new> - - my $perl = TAP::Parser::Source::Perl->new; - -Returns a new C<TAP::Parser::Source::Perl> object. - -=head2 Instance Methods - -=head3 C<source> - -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 { - my $self = shift; - $self->_croak("Cannot find ($_[0][0])") - if @_ && !-f $_[0][0]; - return $self->SUPER::source(@_); -} - -=head3 C<switches> - - my $switches = $perl->switches; - my @switches = $perl->switches; - $perl->switches( \@switches ); - -Getter/setter for the additional switches to pass to the perl executable. One -common switch would be to set an include directory: - - $perl->switches( ['-Ilib'] ); - -=cut - -sub switches { - my $self = shift; - unless (@_) { - return wantarray ? @{ $self->{switches} } : $self->{switches}; - } - my $switches = shift; - $self->{switches} = [@$switches]; # force a copy - return $self; -} - -############################################################################## - -=head3 C<get_stream> - - my $stream = $source->get_stream($parser); - -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, $factory ) = @_; - - my @switches = $self->_switches; - my $path_sep = $Config{path_sep}; - my $path_pat = qr{$path_sep}; - - # Filter out any -I switches to be handled as libs later. - # - # Nasty kludge. It might be nicer if we got the libs separately - # although at least this way we find any -I switches that were - # supplied other then as explicit libs. - # - # We filter out any names containing colons because they will break - # PERL5LIB - my @libs; - my @filtered_switches; - for (@switches) { - if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) { - push @libs, $1; - } - else { - push @filtered_switches, $_; - } - } - @switches = @filtered_switches; - - my $setup = sub { - if (@libs) { - $ENV{PERL5LIB} - = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} ); - } - }; - - # Cargo culted from comments seen elsewhere about VMS / environment - # variables. I don't know if this is actually necessary. - my $previous = $ENV{PERL5LIB}; - my $teardown = sub { - if ( defined $previous ) { - $ENV{PERL5LIB} = $previous; - } - else { - delete $ENV{PERL5LIB}; - } - }; - - # Taint mode ignores environment variables so we must retranslate - # PERL5LIB as -I switches and place PERL5OPT on the command line - # in order that it be seen. - if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) { - push @switches, $self->_libs2switches(@libs); - push @switches, split_shell( $ENV{PERL5OPT} ); - } - - my @command = $self->_get_command_for_switches(@switches) - or $self->_croak("No command found!"); - - return $factory->make_iterator( - { command => \@command, - merge => $self->merge, - setup => $setup, - teardown => $teardown, - } - ); -} - -sub _get_command_for_switches { - my $self = shift; - my @switches = @_; - my ( $file, @args ) = @{ $self->source }; - my $command = $self->_get_perl; - -# 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; -} - -sub _get_command { - my $self = shift; - return $self->_get_command_for_switches( $self->_switches ); -} - -sub _libs2switches { - my $self = shift; - return map {"-I$_"} grep {$_} @_; -} - -=head3 C<shebang> - -Get the shebang line for a script file. - - my $shebang = TAP::Parser::Source::Perl->shebang( $some_script ); - -May be called as a class method - -=cut - -{ - - # Global shebang cache. - my %shebang_for; - - sub _read_shebang { - my $file = shift; - local *TEST; - my $shebang; - if ( open( TEST, $file ) ) { - $shebang = <TEST>; - close(TEST) or print "Can't close $file. $!\n"; - } - else { - print "Can't open $file. $!\n"; - } - return $shebang; - } - - sub shebang { - my ( $class, $file ) = @_; - unless ( exists $shebang_for{$file} ) { - $shebang_for{$file} = _read_shebang($file); - } - return $shebang_for{$file}; - } -} - -=head3 C<get_taint> - -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' ); - - # $untaint will be undefined - my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' ); - -=cut - -sub get_taint { - my ( $class, $shebang ) = @_; - return - unless defined $shebang - && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/; - return $1; -} - -sub _switches { - my $self = shift; - my ( $file, @args ) = @{ $self->source }; - my @switches = ( - $self->switches, - ); - - my $shebang = $self->shebang($file); - return unless defined $shebang; - - my $taint = $self->get_taint($shebang); - push @switches, "-$taint" if defined $taint; - - # Quote the argument if we're VMS, since VMS will downcase anything - # not quoted. - if (IS_VMS) { - for (@switches) { - $_ = qq["$_"]; - } - } - - return @switches; -} - -sub _get_perl { - 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/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm new file mode 100644 index 0000000000..51cff6fe5e --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm @@ -0,0 +1,194 @@ +package TAP::Parser::SourceHandler; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Object (); +use TAP::Parser::Iterator (); + +@ISA = qw(TAP::Object); + +=head1 NAME + +TAP::Parser::SourceHandler - Base class for different TAP source handlers + +=head1 VERSION + +Version 3.21 + +=cut + +$VERSION = '3.21'; + +=head1 SYNOPSIS + + # abstract class - don't use directly! + # see TAP::Parser::IteratorFactory for general usage + + # must be sub-classed for use + package MySourceHandler; + use base qw( TAP::Parser::SourceHandler ); + sub can_handle { return $confidence_level } + sub make_iterator { return $iterator } + + # see example below for more details + +=head1 DESCRIPTION + +This is an abstract base class for L<TAP::Parser::Source> handlers / handlers. + +A C<TAP::Parser::SourceHandler> does whatever is necessary to produce & capture +a stream of TAP from the I<raw> source, and package it up in a +L<TAP::Parser::Iterator> for the parser to consume. + +C<SourceHandlers> must implement the I<source detection & handling> interface +used by L<TAP::Parser::IteratorFactory>. At 2 methods, the interface is pretty +simple: L</can_handle> and L</make_source>. + +Unless you're writing a new L<TAP::Parser::SourceHandler>, a plugin, or +subclassing L<TAP::Parser>, you probably won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C<can_handle> + +I<Abstract method>. + + my $vote = $class->can_handle( $source ); + +C<$source> is a L<TAP::Parser::Source>. + +Returns a number between C<0> & C<1> reflecting how confidently the raw source +can be handled. For example, C<0> means the source cannot handle it, C<0.5> +means it may be able to, and C<1> means it definitely can. See +L<TAP::Parser::IteratorFactory/detect_source> for details on how this is used. + +=cut + +sub can_handle { + my ( $class, $args ) = @_; + $class->_croak( + "Abstract method 'can_handle' not implemented for $class!"); + return; +} + +=head3 C<make_iterator> + +I<Abstract method>. + + my $iterator = $class->make_iterator( $source ); + +C<$source> is a L<TAP::Parser::Source>. + +Returns a new L<TAP::Parser::Iterator> object for use by the L<TAP::Parser>. +C<croak>s on error. + +=cut + +sub make_iterator { + my ( $class, $args ) = @_; + $class->_croak( + "Abstract method 'make_iterator' not implemented for $class!"); + return; +} +1; + +__END__ + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview, and any +of the subclasses that ship with this module as an example. What follows is +a quick overview. + +Start by familiarizing yourself with L<TAP::Parser::Source> and +L<TAP::Parser::IteratorFactory>. L<TAP::Parser::SourceHandler::RawTAP> is +the easiest sub-class to use an an example. + +It's important to point out that if you want your subclass to be automatically +used by L<TAP::Parser> you'll have to and make sure it gets loaded somehow. +If you're using L<prove> you can write an L<App::Prove> plugin. If you're +using L<TAP::Parser> or L<TAP::Harness> directly (eg. through a custom script, +L<ExtUtils::MakeMaker>, or L<Module::Build>) you can use the C<config> option +which will cause L<TAP::Parser::IteratorFactory/load_sources> to load your +subclass). + +Don't forget to register your class with +L<TAP::Parser::IteratorFactory/register_handler>. + +=head2 Example + + package MySourceHandler; + + use strict; + use vars '@ISA'; # compat with older perls + + use MySourceHandler; # see TAP::Parser::SourceHandler + use TAP::Parser::IteratorFactory; + + @ISA = qw( TAP::Parser::SourceHandler ); + + TAP::Parser::IteratorFactory->register_handler( __PACKAGE__ ); + + sub can_handle { + my ( $class, $src ) = @_; + my $meta = $src->meta; + my $config = $src->config_for( $class ); + + if ($config->{accept_all}) { + return 1.0; + } elsif (my $file = $meta->{file}) { + return 0.0 unless $file->{exists}; + return 1.0 if $file->{lc_ext} eq '.tap'; + return 0.9 if $file->{shebang} && $file->{shebang} =~ /^#!.+tap/; + return 0.5 if $file->{text}; + return 0.1 if $file->{binary}; + } elsif ($meta->{scalar}) { + return 0.8 if $$raw_source_ref =~ /\d\.\.\d/; + return 0.6 if $meta->{has_newlines}; + } elsif ($meta->{array}) { + return 0.8 if $meta->{size} < 5; + return 0.6 if $raw_source_ref->[0] =~ /foo/; + return 0.5; + } elsif ($meta->{hash}) { + return 0.6 if $raw_source_ref->{foo}; + return 0.2; + } + + return 0; + } + + sub make_iterator { + my ($class, $source) = @_; + # this is where you manipulate the source and + # capture the stream of TAP in an iterator + # either pick a TAP::Parser::Iterator::* or write your own... + my $iterator = TAP::Parser::Iterator::Array->new([ 'foo', 'bar' ]); + return $iterator; + } + + 1; + +=head1 AUTHORS + +TAPx Developers. + +Source detection stuff added by Steve Purkis + +=head1 SEE ALSO + +L<TAP::Object>, +L<TAP::Parser>, +L<TAP::Parser::Source>, +L<TAP::Parser::Iterator>, +L<TAP::Parser::IteratorFactory>, +L<TAP::Parser::SourceHandler::Executable>, +L<TAP::Parser::SourceHandler::Perl>, +L<TAP::Parser::SourceHandler::File>, +L<TAP::Parser::SourceHandler::Handle>, +L<TAP::Parser::SourceHandler::RawTAP> + +=cut + diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm new file mode 100644 index 0000000000..abfd5c52d2 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm @@ -0,0 +1,185 @@ +package TAP::Parser::SourceHandler::Executable; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::SourceHandler (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Process (); + +@ISA = qw(TAP::Parser::SourceHandler); + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::Executable - Stream output from an executable TAP source + +=head1 VERSION + +Version 3.21 + +=cut + +$VERSION = '3.21'; + +=head1 SYNOPSIS + + use TAP::Parser::Source; + use TAP::Parser::SourceHandler::Executable; + + my $source = TAP::Parser::Source->new->raw(['/usr/bin/ruby', 'mytest.rb']); + $source->assemble_meta; + + my $class = 'TAP::Parser::SourceHandler::Executable'; + my $vote = $class->can_handle( $source ); + my $iter = $class->make_iterator( $source ); + +=head1 DESCRIPTION + +This is an I<executable> L<TAP::Parser::SourceHandler> - it has 2 jobs: + +1. Figure out if the L<TAP::Parser::Source> it's given is an executable command +(L</can_handle>). + +2. Creates an iterator for executable commands (L</make_iterator>). + +Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C<can_handle> + + my $vote = $class->can_handle( $source ); + +Only votes if $source looks like an executable file. Casts the following votes: + + 0.9 if it's a hash with an 'exec' key + 0.8 if it's a .sh file + 0.8 if it's a .bat file + 0.75 if it's got an execute bit set + +=cut + +sub can_handle { + my ( $class, $src ) = @_; + my $meta = $src->meta; + + if ( $meta->{is_file} ) { + my $file = $meta->{file}; + + # Note: we go in low so we can be out-voted + return 0.8 if $file->{lc_ext} eq '.sh'; + return 0.8 if $file->{lc_ext} eq '.bat'; + return 0.7 if $file->{execute}; + } + elsif ( $meta->{is_hash} ) { + return 0.9 if $src->raw->{exec}; + } + + return 0; +} + +=head3 C<make_iterator> + + my $iterator = $class->make_iterator( $source ); + +Returns a new L<TAP::Parser::Iterator::Process> for the source. +C<$source-E<gt>raw> must be in one of the following forms: + + { exec => [ @exec ] } + + [ @exec ] + + $file + +C<croak>s on error. + +=cut + +sub make_iterator { + my ( $class, $source ) = @_; + my $meta = $source->meta; + + my @command; + if ( $meta->{is_hash} ) { + @command = @{ $source->raw->{exec} || [] }; + } + elsif ( $meta->{is_scalar} ) { + @command = ${ $source->raw }; + } + elsif ( $meta->{is_array} ) { + @command = @{ $source->raw }; + } + + $class->_croak('No command found in $source->raw!') unless @command; + + $class->_autoflush( \*STDOUT ); + $class->_autoflush( \*STDERR ); + + return $class->iterator_class->new( + { command => \@command, + merge => $source->merge + } + ); +} + +=head3 C<iterator_class> + +The class of iterator to use, override if you're sub-classing. Defaults +to L<TAP::Parser::Iterator::Process>. + +=cut + +use constant iterator_class => 'TAP::Parser::Iterator::Process'; + +# Turns on autoflush for the handle passed +sub _autoflush { + my ( $class, $flushed ) = @_; + my $old_fh = select $flushed; + $| = 1; + select $old_fh; +} + +1; + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. + +=head2 Example + + package MyRubySourceHandler; + + use strict; + use vars '@ISA'; + + use Carp qw( croak ); + use TAP::Parser::SourceHandler::Executable; + + @ISA = qw( TAP::Parser::SourceHandler::Executable ); + + # expect $handler->(['mytest.rb', 'cmdline', 'args']); + sub make_iterator { + my ($self, $source) = @_; + my @test_args = @{ $source->test_args }; + my $rb_file = $test_args[0]; + croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file); + return $self->SUPER::raw_source(['/usr/bin/ruby', @test_args]); + } + +=head1 SEE ALSO + +L<TAP::Object>, +L<TAP::Parser>, +L<TAP::Parser::IteratorFactory>, +L<TAP::Parser::SourceHandler>, +L<TAP::Parser::SourceHandler::Perl>, +L<TAP::Parser::SourceHandler::File>, +L<TAP::Parser::SourceHandler::Handle>, +L<TAP::Parser::SourceHandler::RawTAP> + +=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm new file mode 100644 index 0000000000..4e411631bd --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm @@ -0,0 +1,136 @@ +package TAP::Parser::SourceHandler::File; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::SourceHandler (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Stream (); + +@ISA = qw(TAP::Parser::SourceHandler); + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::File - Stream TAP from a text file. + +=head1 VERSION + +Version 3.21 + +=cut + +$VERSION = '3.21'; + +=head1 SYNOPSIS + + use TAP::Parser::Source; + use TAP::Parser::SourceHandler::File; + + my $source = TAP::Parser::Source->new->raw( \'file.tap' ); + $source->assemble_meta; + + my $class = 'TAP::Parser::SourceHandler::File'; + my $vote = $class->can_handle( $source ); + my $iter = $class->make_iterator( $source ); + +=head1 DESCRIPTION + +This is a I<raw TAP stored in a file> L<TAP::Parser::SourceHandler> - it has 2 jobs: + +1. Figure out if the I<raw> source it's given is a file containing raw TAP +output. See L<TAP::Parser::IteratorFactory> for more details. + +2. Takes raw TAP from the text file given, and converts into an iterator. + +Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C<can_handle> + + my $vote = $class->can_handle( $source ); + +Only votes if $source looks like a regular file. Casts the following votes: + + 0.9 if it's a .tap file + 0.9 if it has an extension matching any given in user config. + +=cut + +sub can_handle { + my ( $class, $src ) = @_; + my $meta = $src->meta; + my $config = $src->config_for($class); + + return 0 unless $meta->{is_file}; + my $file = $meta->{file}; + return 0.9 if $file->{lc_ext} eq '.tap'; + + if ( my $exts = $config->{extensions} ) { + return 0.9 if grep { lc($_) eq $file->{lc_ext} } @$exts; + } + + return 0; +} + +=head3 C<make_iterator> + + my $iterator = $class->make_iterator( $source ); + +Returns a new L<TAP::Parser::Iterator::Stream> for the source. C<croak>s +on error. + +=cut + +sub make_iterator { + my ( $class, $source ) = @_; + + $class->_croak('$source->raw must be a scalar ref') + unless $source->meta->{is_scalar}; + + my $file = ${ $source->raw }; + my $fh; + open( $fh, '<', $file ) + or $class->_croak("error opening TAP source file '$file': $!"); + return $class->iterator_class->new($fh); +} + +=head3 C<iterator_class> + +The class of iterator to use, override if you're sub-classing. Defaults +to L<TAP::Parser::Iterator::Stream>. + +=cut + +use constant iterator_class => 'TAP::Parser::Iterator::Stream'; + +1; + +__END__ + +=head1 CONFIGURATION + + { + extensions => [ @case_insensitive_exts_to_match ] + } + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. + +=head1 SEE ALSO + +L<TAP::Object>, +L<TAP::Parser>, +L<TAP::Parser::SourceHandler>, +L<TAP::Parser::SourceHandler::Executable>, +L<TAP::Parser::SourceHandler::Perl>, +L<TAP::Parser::SourceHandler::Handle>, +L<TAP::Parser::SourceHandler::RawTAP> + +=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm new file mode 100644 index 0000000000..6a71eef8a0 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm @@ -0,0 +1,125 @@ +package TAP::Parser::SourceHandler::Handle; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::SourceHandler (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Stream (); + +@ISA = qw(TAP::Parser::SourceHandler); + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::Handle - Stream TAP from an IO::Handle or a GLOB. + +=head1 VERSION + +Version 3.21 + +=cut + +$VERSION = '3.21'; + +=head1 SYNOPSIS + + use TAP::Parser::Source; + use TAP::Parser::SourceHandler::Executable; + + my $source = TAP::Parser::Source->new->raw( \*TAP_FILE ); + $source->assemble_meta; + + my $class = 'TAP::Parser::SourceHandler::Handle'; + my $vote = $class->can_handle( $source ); + my $iter = $class->make_iterator( $source ); + +=head1 DESCRIPTION + +This is a I<raw TAP stored in an IO Handle> L<TAP::Parser::SourceHandler> class. It +has 2 jobs: + +1. Figure out if the L<TAP::Parser::Source> it's given is an L<IO::Handle> or +GLOB containing raw TAP output (L</can_handle>). + +2. Creates an iterator for IO::Handle's & globs (L</make_iterator>). + +Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C<can_handle> + + my $vote = $class->can_handle( $source ); + +Casts the following votes: + + 0.9 if $source is an IO::Handle + 0.8 if $source is a glob + +=cut + +sub can_handle { + my ( $class, $src ) = @_; + my $meta = $src->meta; + + return 0.9 + if $meta->{is_object} + && UNIVERSAL::isa( $src->raw, 'IO::Handle' ); + + return 0.8 if $meta->{is_glob}; + + return 0; +} + +=head3 C<make_iterator> + + my $iterator = $class->make_iterator( $source ); + +Returns a new L<TAP::Parser::Iterator::Stream> for the source. + +=cut + +sub make_iterator { + my ( $class, $source ) = @_; + + $class->_croak('$source->raw must be a glob ref or an IO::Handle') + unless $source->meta->{is_glob} + || UNIVERSAL::isa( $source->raw, 'IO::Handle' ); + + return $class->iterator_class->new( $source->raw ); +} + +=head3 C<iterator_class> + +The class of iterator to use, override if you're sub-classing. Defaults +to L<TAP::Parser::Iterator::Stream>. + +=cut + +use constant iterator_class => 'TAP::Parser::Iterator::Stream'; + +1; + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. + +=head1 SEE ALSO + +L<TAP::Object>, +L<TAP::Parser>, +L<TAP::Parser::Iterator>, +L<TAP::Parser::Iterator::Stream>, +L<TAP::Parser::IteratorFactory>, +L<TAP::Parser::SourceHandler>, +L<TAP::Parser::SourceHandler::Executable>, +L<TAP::Parser::SourceHandler::Perl>, +L<TAP::Parser::SourceHandler::File>, +L<TAP::Parser::SourceHandler::RawTAP> + +=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm new file mode 100644 index 0000000000..7ad427e1f4 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm @@ -0,0 +1,310 @@ +package TAP::Parser::SourceHandler::Perl; + +use strict; +use Config; +use vars qw($VERSION @ISA); + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); +use constant IS_VMS => ( $^O eq 'VMS' ); + +use TAP::Parser::SourceHandler::Executable (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Process (); +use TAP::Parser::Utils qw( split_shell ); + +@ISA = 'TAP::Parser::SourceHandler::Executable'; + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::Perl - Stream TAP from a Perl executable + +=head1 VERSION + +Version 3.21 + +=cut + +$VERSION = '3.21'; + +=head1 SYNOPSIS + + use TAP::Parser::Source; + use TAP::Parser::SourceHandler::Perl; + + my $source = TAP::Parser::Source->new->raw( \'script.pl' ); + $source->assemble_meta; + + my $class = 'TAP::Parser::SourceHandler::Perl'; + my $vote = $class->can_handle( $source ); + my $iter = $class->make_iterator( $source ); + +=head1 DESCRIPTION + +This is a I<Perl> L<TAP::Parser::SourceHandler> - it has 2 jobs: + +1. Figure out if the L<TAP::Parser::Source> it's given is actually a Perl +script (L</can_handle>). + +2. Creates an iterator for Perl sources (L</make_iterator>). + +Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C<can_handle> + + my $vote = $class->can_handle( $source ); + +Only votes if $source looks like a file. Casts the following votes: + + 0.9 if it has a shebang ala "#!...perl" + 0.8 if it's a .t file + 0.9 if it's a .pl file + 0.75 if it's in a 't' directory + 0.25 by default (backwards compat) + +=cut + +sub can_handle { + my ( $class, $source ) = @_; + my $meta = $source->meta; + + return 0 unless $meta->{is_file}; + my $file = $meta->{file}; + + if ( my $shebang = $file->{shebang} ) { + return 0.9 if $shebang =~ /^#!.*\bperl/; + } + + return 0.8 if $file->{lc_ext} eq '.t'; # vote higher than Executable + return 0.9 if $file->{lc_ext} eq '.pl'; + + return 0.75 if $file->{dir} =~ /^t\b/; # vote higher than Executable + + # backwards compat, always vote: + return 0.25; +} + +=head3 C<make_iterator> + + my $iterator = $class->make_iterator( $source ); + +Constructs & returns a new L<TAP::Parser::Iterator::Process> for the source. +Assumes C<$source-E<gt>raw> contains a reference to the perl script. C<croak>s +if the file could not be found. + +The command to run is built as follows: + + $perl @switches $perl_script @test_args + +The perl command to use is determined by L</get_perl>. The command generated +is guaranteed to preserve: + + PERL5LIB + PERL5OPT + Taint Mode, if set in the script's shebang + +I<Note:> the command generated will I<not> respect any shebang line defined in +your Perl script. This is only a problem if you have compiled a custom version +of Perl or if you want to use a specific version of Perl for one test and a +different version for another, for example: + + #!/path/to/a/custom_perl --some --args + #!/usr/local/perl-5.6/bin/perl -w + +Currently you need to write a plugin to get around this. + +=cut + +sub make_iterator { + my ( $class, $source ) = @_; + my $meta = $source->meta; + my $perl_script = ${ $source->raw }; + + $class->_croak("Cannot find ($perl_script)") unless $meta->{is_file}; + + # TODO: does this really need to be done here? + $class->_autoflush( \*STDOUT ); + $class->_autoflush( \*STDERR ); + + my @switches = $class->_switches($source); + my $path_sep = $Config{path_sep}; + my $path_re = qr{$path_sep}; + + # Filter out any -I switches to be handled as libs later. + # + # Nasty kludge. It might be nicer if we got the libs separately + # although at least this way we find any -I switches that were + # supplied other then as explicit libs. + # + # We filter out any names containing colons because they will break + # PERL5LIB + my @libs; + my @filtered_switches; + for (@switches) { + if ( !/$path_re/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) { + push @libs, $1; + } + else { + push @filtered_switches, $_; + } + } + @switches = @filtered_switches; + + my $setup = sub { + if (@libs) { + $ENV{PERL5LIB} + = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} ); + } + }; + + # Cargo culted from comments seen elsewhere about VMS / environment + # variables. I don't know if this is actually necessary. + my $previous = $ENV{PERL5LIB}; + my $teardown = sub { + if ( defined $previous ) { + $ENV{PERL5LIB} = $previous; + } + else { + delete $ENV{PERL5LIB}; + } + }; + + # Taint mode ignores environment variables so we must retranslate + # PERL5LIB as -I switches and place PERL5OPT on the command line + # in order that it be seen. + if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) { + push @switches, $class->_libs2switches(@libs); + push @switches, split_shell( $ENV{PERL5OPT} ); + } + + my @command = $class->_get_command_for_switches( $source, @switches ) + or $class->_croak("No command found!"); + + return TAP::Parser::Iterator::Process->new( + { command => \@command, + merge => $source->merge, + setup => $setup, + teardown => $teardown, + } + ); +} + +sub _get_command_for_switches { + my ( $class, $source, @switches ) = @_; + my $file = ${ $source->raw }; + my @args = @{ $source->test_args || [] }; + my $command = $class->get_perl; + + # XXX don't 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; +} + +sub _libs2switches { + my $class = shift; + return map {"-I$_"} grep {$_} @_; +} + +=head3 C<get_taint> + +Decode any taint switches from a Perl shebang line. + + # $taint will be 't' + my $taint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl -t' ); + + # $untaint will be undefined + my $untaint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl' ); + +=cut + +sub get_taint { + my ( $class, $shebang ) = @_; + return + unless defined $shebang + && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/; + return $1; +} + +sub _switches { + my ( $class, $source ) = @_; + my $file = ${ $source->raw }; + my @args = @{ $source->test_args || [] }; + my @switches = @{ $source->switches || [] }; + my $shebang = $source->meta->{file}->{shebang}; + return unless defined $shebang; + + my $taint = $class->get_taint($shebang); + push @switches, "-$taint" if defined $taint; + + # Quote the argument if we're VMS, since VMS will downcase anything + # not quoted. + if (IS_VMS) { + for (@switches) { + $_ = qq["$_"]; + } + } + + return @switches; +} + +=head3 C<get_perl> + +Gets the version of Perl currently running the test suite. + +=cut + +sub get_perl { + my $class = shift; + return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL}; + return Win32::GetShortPathName($^X) if IS_WIN32; + return $^X; +} + +1; + +__END__ + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. + +=head2 Example + + package MyPerlSourceHandler; + + use strict; + use vars '@ISA'; + + use TAP::Parser::SourceHandler::Perl; + + @ISA = qw( TAP::Parser::SourceHandler::Perl ); + + # 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::IteratorFactory>, +L<TAP::Parser::SourceHandler>, +L<TAP::Parser::SourceHandler::Executable>, +L<TAP::Parser::SourceHandler::File>, +L<TAP::Parser::SourceHandler::Handle>, +L<TAP::Parser::SourceHandler::RawTAP> + +=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm new file mode 100644 index 0000000000..9978e5c327 --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm @@ -0,0 +1,131 @@ +package TAP::Parser::SourceHandler::RawTAP; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::SourceHandler (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Array (); + +@ISA = qw(TAP::Parser::SourceHandler); + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::RawTAP - Stream output from raw TAP in a scalar/array ref. + +=head1 VERSION + +Version 3.21 + +=cut + +$VERSION = '3.21'; + +=head1 SYNOPSIS + + use TAP::Parser::Source; + use TAP::Parser::SourceHandler::RawTAP; + + my $source = TAP::Parser::Source->new->raw( \"1..1\nok 1\n" ); + $source->assemble_meta; + + my $class = 'TAP::Parser::SourceHandler::RawTAP'; + my $vote = $class->can_handle( $source ); + my $iter = $class->make_iterator( $source ); + +=head1 DESCRIPTION + +This is a I<raw TAP output> L<TAP::Parser::SourceHandler> - it has 2 jobs: + +1. Figure out if the L<TAP::Parser::Source> it's given is raw TAP output +(L</can_handle>). + +2. Creates an iterator for raw TAP output (L</make_iterator>). + +Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C<can_handle> + + my $vote = $class->can_handle( $source ); + +Only votes if $source is an array, or a scalar with newlines. Casts the +following votes: + + 0.9 if it's a scalar with '..' in it + 0.7 if it's a scalar with 'ok' in it + 0.3 if it's just a scalar with newlines + 0.5 if it's an array + +=cut + +sub can_handle { + my ( $class, $src ) = @_; + my $meta = $src->meta; + + return 0 if $meta->{file}; + if ( $meta->{is_scalar} ) { + return 0 unless $meta->{has_newlines}; + return 0.9 if ${ $src->raw } =~ /\d\.\.\d/; + return 0.7 if ${ $src->raw } =~ /ok/; + return 0.3; + } + elsif ( $meta->{is_array} ) { + return 0.5; + } + return 0; +} + +=head3 C<make_iterator> + + my $iterator = $class->make_iterator( $source ); + +Returns a new L<TAP::Parser::Iterator::Array> for the source. +C<$source-E<gt>raw> must be an array ref, or a scalar ref. + +C<croak>s on error. + +=cut + +sub make_iterator { + my ( $class, $src ) = @_; + my $meta = $src->meta; + + my $tap_array; + if ( $meta->{is_scalar} ) { + $tap_array = [ split "\n" => ${ $src->raw } ]; + } + elsif ( $meta->{is_array} ) { + $tap_array = $src->raw; + } + + $class->_croak('No raw TAP found in $source->raw') + unless scalar $tap_array; + + return TAP::Parser::Iterator::Array->new($tap_array); +} + +1; + +=head1 SUBCLASSING + +Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. + +=head1 SEE ALSO + +L<TAP::Object>, +L<TAP::Parser>, +L<TAP::Parser::IteratorFactory>, +L<TAP::Parser::SourceHandler>, +L<TAP::Parser::SourceHandler::Executable>, +L<TAP::Parser::SourceHandler::Perl>, +L<TAP::Parser::SourceHandler::File>, +L<TAP::Parser::SourceHandler::Handle> + +=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/pgTAP.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/pgTAP.pm new file mode 100644 index 0000000000..95c6e52cfc --- /dev/null +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/pgTAP.pm @@ -0,0 +1,253 @@ +package TAP::Parser::SourceHandler::pgTAP; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Parser::IteratorFactory (); +use TAP::Parser::Iterator::Process (); + +@ISA = qw(TAP::Parser::SourceHandler); +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +=head1 NAME + +TAP::Parser::SourceHandler::pgTAP - Stream TAP from pgTAP test scripts + +=head1 VERSION + +Version 3.21 + +=cut + +$VERSION = '3.21'; + +=head1 SYNOPSIS + +In F<Build.PL> for your application with pgTAP tests in F<t/*.pg>: + + Module::Build->new( + module_name => 'MyApp', + test_file_exts => [qw(.t .pg)], + use_tap_harness => 1, + tap_harness_args => { + sources => { + Perl => undef, + pgTAP => { + dbname => 'try', + username => 'postgres', + suffix => '.pg', + }, + } + }, + build_requires => { + 'Module::Build' => '0.30', + 'TAP::Parser::SourceHandler::pgTAP' => '3.19', + }, + )->create_build_script; + +If you're using L<C<prove>|prove>: + + prove --source Perl \ + --source pgTAP --pgtap-option dbname=try \ + --pgtap-option username=postgres \ + --pgtap-option suffix=.pg + +Direct use: + + use TAP::Parser::Source; + use TAP::Parser::SourceHandler::pgTAP; + + my $source = TAP::Parser::Source->new->raw(\'mytest.pg'); + $source->config({ pgTAP => { + dbname => 'testing', + username => 'postgres', + suffix => '.pg', + }); + $source->assemble_meta; + + my $class = 'TAP::Parser::SourceHandler::pgTAP'; + my $vote = $class->can_handle( $source ); + my $iter = $class->make_iterator( $source ); + +=head1 DESCRIPTION + +This source handler executes pgTAP tests. It does two things: + +=over + +=item 1. + +Looks at the L<TAP::Parser::Source> passed to it to determine whether or not +the source in question is in fact a pgTAP test (L</can_handle>). + +=item 2. + +Creates an iterator that will call C<psql> to run the pgTAP tests +(L</make_iterator>). + +=back + +Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably +won't need to use this module directly. + +=head1 METHODS + +=head2 Class Methods + +=head3 C<can_handle> + + my $vote = $class->can_handle( $source ); + +Looks at the source to determine whether or not it's a pgTAP test file and +returns a score for how likely it is in fact a pgTAP test file. The scores are +as follows: + + 1 if it has a suffix equal to that in the "suffix" config + 1 if its suffix is ".pg" + 0.8 if its suffix is ".sql" + 0.75 if its suffix is ".s" + +The latter two scores are subject to change, so try to name your pgTAP tests +ending in ".pg" or specify a suffix in the configuration to be sure. + +=cut + +sub can_handle { + my ( $class, $source ) = @_; + my $meta = $source->meta; + + return 0 unless $meta->{is_file}; + + my $suf = $meta->{file}{lc_ext}; + + # If the config specifies a suffix, it's required. + if ( my $config = $source->config_for('pgTAP') ) { + if ( defined $config->{suffix} ) { + return $suf eq $config->{suffix} ? 1 : 0; + } + } + + # Otherwise, return a score for our supported suffixes. + my %score_for = ( + '.pg' => 0.9, + '.sql' => 0.8, + '.s' => 0.75, + ); + return $score_for{$suf} || 0; +} + +=head3 C<make_iterator> + + my $iterator = $class->make_iterator( $source ); + +Returns a new L<TAP::Parser::Iterator::Process> for the source. C<< +$source->raw >> must be either a file name or a scalar reference to the file +name. + +The pgTAP tests are run by executing C<psql>, the PostgreSQL command-line +utility. A number of arguments are passed to it, many of which you can effect +by setting up the source source configuration. The configuration must be a +hash reference, and supports the following keys: + +=over + +=item C<psql> + +The path to the C<psql> command. Defaults to simply "psql", which should work +well enough if it's in your path. + +=item C<dbname> + +The database to which to connect to run the tests. Defaults to the value of +the C<$PGDATABASE> environment variable or, if not set, to the system +username. + +=item C<username> + +The PostgreSQL username to use to connect to PostgreSQL. If not specified, no +username will be used, in which case C<psql> will fall back on either the +C<$PGUSER> environment variable or, if not set, the system username. + +=item C<host> + +Specifies the host name of the machine to which to connect to the PostgreSQL +server. If the value begins with a slash, it is used as the directory for the +Unix-domain socket. Defaults to the value of the C<$PGDATABASE> environment +variable or, if not set, the local host. + +=item C<port> + +Specifies the TCP port or the local Unix-domain socket file extension on which +the server is listening for connections. Defaults to the value of the +C<$PGPORT> environment variable or, if not set, to the port specified at the +time C<psql> was compiled, usually 5432. + +=begin comment + +=item C<search_path> + +The schema search path to use during the execution of the tests. Useful for +overriding the default search path and you have pgTAP installed in a schema +not included in that search path. + +=end comment + +=back + +=cut + +sub make_iterator { + my ( $class, $source ) = @_; + my $config = $source->config_for('pgTAP'); + + my @command = ( $config->{psql} || 'psql' ); + push @command, qw( + --no-psqlrc + --no-align + --quiet + --pset pager= + --pset tuples_only=true + --set ON_ERROR_ROLLBACK=1 + --set ON_ERROR_STOP=1 + ); + + for (qw(username host port dbname)) { + push @command, "--$_" => $config->{$_} if defined $config->{$_}; + } + + my $fn = ref $source->raw ? ${ $source->raw } : $source->raw; + $class->_croak( + 'No such file or directory: ' . ( defined $fn ? $fn : '' ) ) + unless $fn && -e $fn; + + push @command, '--file', $fn; + + # XXX I'd like a way to be able to specify environment variables to set when + # the iterator executes the command... + # local $ENV{PGOPTIONS} = "--search_path=$config->{search_path}" + # if $config->{search_path}; + + return TAP::Parser::Iterator::Process->new( + { command => \@command, + merge => $source->merge + } + ); +} + +=head1 SEE ALSO + +L<TAP::Object>, +L<TAP::Parser>, +L<TAP::Parser::IteratorFactory>, +L<TAP::Parser::SourceHandler>, +L<TAP::Parser::SourceHandler::Executable>, +L<TAP::Parser::SourceHandler::Perl>, +L<TAP::Parser::SourceHandler::File>, +L<TAP::Parser::SourceHandler::Handle>, +L<TAP::Parser::SourceHandler::RawTAP> + +=head1 AUTHOR + +David E. Wheeler <dwheeler@cpan.org> + +=cut diff --git a/cpan/Test-Harness/lib/TAP/Parser/Utils.pm b/cpan/Test-Harness/lib/TAP/Parser/Utils.pm index a3d2dd1ea9..e7c5345b09 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Utils.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Utils.pm @@ -13,11 +13,11 @@ TAP::Parser::Utils - Internal TAP::Parser utilities =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm index 524d7dca8d..a5771592bb 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm @@ -6,7 +6,7 @@ use vars qw($VERSION @ISA); use TAP::Object (); @ISA = 'TAP::Object'; -$VERSION = '3.17'; +$VERSION = '3.21'; # TODO: # Handle blessed object syntax @@ -270,7 +270,7 @@ TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator =head1 VERSION -Version 3.17 +Version 3.21 =head1 SYNOPSIS @@ -294,7 +294,7 @@ C<TAP::Parser::YAMLish::Reader> object. =head3 C<read> - my $got = $reader->read($stream); + my $got = $reader->read($iterator); Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it represents. diff --git a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm index ed81f6d819..a20b6252fa 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm @@ -6,7 +6,7 @@ use vars qw($VERSION @ISA); use TAP::Object (); @ISA = 'TAP::Object'; -$VERSION = '3.17'; +$VERSION = '3.21'; my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x; my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x; @@ -147,7 +147,7 @@ TAP::Parser::YAMLish::Writer - Write YAMLish data =head1 VERSION -Version 3.17 +Version 3.21 =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/Test/Harness.pm b/cpan/Test-Harness/lib/Test/Harness.pm index eba3c5efc4..a528301144 100644 --- a/cpan/Test-Harness/lib/Test/Harness.pm +++ b/cpan/Test-Harness/lib/Test/Harness.pm @@ -7,9 +7,10 @@ use strict; use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); use constant IS_VMS => ( $^O eq 'VMS' ); -use TAP::Harness (); -use TAP::Parser::Aggregator (); -use TAP::Parser::Source::Perl (); +use TAP::Harness (); +use TAP::Parser::Aggregator (); +use TAP::Parser::Source (); +use TAP::Parser::SourceHandler::Perl (); use TAP::Parser::Utils qw( split_shell ); @@ -27,6 +28,7 @@ use vars qw( $Directives $Timer $Strap + $HarnessSubclass $has_time_hires $IgnoreExit ); @@ -44,11 +46,11 @@ Test::Harness - Run Perl standard test scripts with statistics =head1 VERSION -Version 3.17 +Version 3.21 =cut -$VERSION = '3.17'; +$VERSION = '3.21'; # Backwards compatibility for exportable variable names. *verbose = *Verbose; @@ -118,8 +120,8 @@ one of the messages in the DIAGNOSTICS section. sub _has_taint { my $test = shift; - return TAP::Parser::Source::Perl->get_taint( - TAP::Parser::Source::Perl->shebang($test) ); + return TAP::Parser::SourceHandler::Perl->get_taint( + TAP::Parser::Source->shebang($test) ); } sub _aggregate { @@ -250,7 +252,8 @@ sub _new_harness { } } - return TAP::Harness->new($args); + my $class = $ENV{HARNESS_SUBCLASS} || 'TAP::Harness'; + return TAP::Harness->_construct( $class, $args ); } # Get the parts of @INC which are changed from the stock list AND @@ -268,7 +271,7 @@ sub _filtered_inc { elsif (IS_WIN32) { # Lose any trailing backslashes in the Win32 paths - s/[\\\/]+$// foreach @inc; + s/[\\\/]+$// for @inc; } my @default_inc = _default_inc(); @@ -305,7 +308,7 @@ sub _filtered_inc { my $perl = $ENV{HARNESS_PERL} || $^X; # Avoid using -l for the benefit of Perl 6 - chomp( @inc = `$perl -e "print join qq[\\n], \@INC, q[]"` ); + chomp( @inc = `"$perl" -e "print join qq[\\n], \@INC, q[]"` ); return @inc; } } @@ -528,15 +531,19 @@ Provide additional options to the harness. Currently supported options are: Run <n> (default 9) parallel jobs. -=item C<< f >> +=item C<< c >> -Use forked parallelism. +Try to color output. See L<TAP::Formatter::Base/"new">. =back Multiple options may be separated by colons: - HARNESS_OPTIONS=j9:f make test + HARNESS_OPTIONS=j9:c make test + +=item C<HARNESS_SUBCLASS> + +Specifies a TAP::Harness subclass to be used in place of TAP::Harness. =back @@ -546,10 +553,9 @@ Normally when a Perl program is run in taint mode the contents of the C<PERL5LIB> environment variable do not appear in C<@INC>. Because C<PERL5LIB> is often used during testing to add build -directories to C<@INC> C<Test::Harness> (actually -L<TAP::Parser::Source::Perl>) passes the names of any directories found -in C<PERL5LIB> as -I switches. The net effect of this is that -C<PERL5LIB> is honoured even in taint mode. +directories to C<@INC> C<Test::Harness> passes the names of any +directories found in C<PERL5LIB> as -I switches. The net effect of this +is that C<PERL5LIB> is honoured even in taint mode. =head1 SEE ALSO diff --git a/cpan/Test-Harness/t/000-load.t b/cpan/Test-Harness/t/000-load.t index 58d41bfeeb..24addddc44 100644 --- a/cpan/Test-Harness/t/000-load.t +++ b/cpan/Test-Harness/t/000-load.t @@ -1,61 +1,95 @@ -#!/usr/bin/perl -wT +#!/usr/bin/perl -w use strict; use lib 't/lib'; -use Test::More tests => 78; - -BEGIN { - - # TAP::Parser must come first - my @classes = qw( - TAP::Parser - App::Prove - App::Prove::State - App::Prove::State::Result - App::Prove::State::Result::Test - TAP::Base - TAP::Formatter::Color - TAP::Formatter::Console::ParallelSession - TAP::Formatter::Console::Session - TAP::Formatter::Console - 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::IteratorFactory - TAP::Parser::Multiplexer - TAP::Parser::Result - TAP::Parser::ResultFactory - TAP::Parser::Result::Bailout - TAP::Parser::Result::Comment - TAP::Parser::Result::Plan - TAP::Parser::Result::Pragma - TAP::Parser::Result::Test - TAP::Parser::Result::Unknown - 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 - TAP::Parser::YAMLish::Writer - TAP::Parser::Utils - Test::Harness - ); - - foreach my $class (@classes) { - use_ok $class or BAIL_OUT("Could not load $class"); - is $class->VERSION, TAP::Parser->VERSION, - "... and $class should have the correct version"; +use Test::More; + +use constant LIBS => 'lib/'; +use constant FIRST => 'TAP::Parser'; + +read_manifest( 'MANIFEST', my $manifest = {} ); +read_manifest( 'MANIFEST.CUMMULATIVE', my $manifest_cummulative = {} ); + +my @classes = uniq( + FIRST, + map { file_to_mod($_) } filter_lib( keys %$manifest ) +); + +plan tests => @classes * 2 + 1; + +for my $class (@classes) { + use_ok $class or BAIL_OUT("Could not load $class"); + is $class->VERSION, TAP::Parser->VERSION, + "... and $class should have the correct version"; +} + +my @orphans = diff( + [ filter_lib( keys %$manifest ) ], + [ filter_lib( keys %$manifest_cummulative ) ] +); +my @waifs = intersection( \@orphans, [ keys %INC ] ); +unless ( ok 0 == @waifs, 'no old versions loaded' ) { + diag "\nThe following modules were loaded in error:\n"; + for my $waif ( sort @waifs ) { + diag sprintf " %s (%s)\n", file_to_mod($waif), $INC{$waif}; } + diag "\n"; +} + +diag("Testing Test::Harness $Test::Harness::VERSION, Perl $], $^X") + unless $ENV{PERL_CORE}; + +sub intersection { + my ( $la, $lb ) = @_; + my %seen = map { $_ => 1 } @$la; + return grep { $seen{$_} } @$lb; +} + +sub diff { + my ( $la, $lb ) = @_; + my %seen = map { $_ => 1 } @$la; + return grep { !$seen{$_}++ } @$lb; +} - diag("Testing Test::Harness $Test::Harness::VERSION, Perl $], $^X") - unless $ENV{PERL_CORE}; +sub uniq { + my %seen = (); + grep { !$seen{$_}++ } @_; } + +sub lib_matcher { + my @libs = @_; + my $re = join ')|(', map quotemeta, @libs; + return qr{^($re)}; +} + +sub filter_lib { + my $matcher = lib_matcher(LIBS); + return map { s{$matcher}{}; $_ } + grep {m{$matcher.+?\.pm$}} sort @_; +} + +sub mod_to_file { + my $mod = shift; + $mod =~ s{::}{/}g; + return "$mod.pm"; +} + +sub file_to_mod { + my $file = shift; + $file =~ s{/}{::}g; + $file =~ s{\.pm$}{}; + return $file; +} + +sub read_manifest { + my ( $file, $into ) = @_; + open my $fh, '<', $file or die "Can't read $file: $!"; + while (<$fh>) { + chomp; + s/\s*#.*//; + $into->{$_}++ if length $_; + } + return; +} + diff --git a/cpan/Test-Harness/t/aggregator.t b/cpan/Test-Harness/t/aggregator.t index c8e32a1c93..3656208dc3 100644 --- a/cpan/Test-Harness/t/aggregator.t +++ b/cpan/Test-Harness/t/aggregator.t @@ -6,7 +6,7 @@ use lib 't/lib'; use Test::More tests => 81; use TAP::Parser; -use TAP::Parser::IteratorFactory; +use TAP::Parser::Iterator::Array; use TAP::Parser::Aggregator; my $tap = <<'END_TAP'; @@ -20,11 +20,10 @@ not ok 4 - this is a real failure ok 5 # skip we have no description END_TAP -my $factory = TAP::Parser::IteratorFactory->new; -my $stream = $factory->make_iterator( [ split /\n/ => $tap ] ); -isa_ok $stream, 'TAP::Parser::Iterator'; +my $iterator = TAP::Parser::Iterator::Array->new( [ split /\n/ => $tap ] ); +isa_ok $iterator, 'TAP::Parser::Iterator'; -my $parser1 = TAP::Parser->new( { stream => $stream } ); +my $parser1 = TAP::Parser->new( { iterator => $iterator } ); isa_ok $parser1, 'TAP::Parser'; $parser1->run; @@ -149,7 +148,7 @@ my $gp = $agg->_get_parsers(qw(tap1 tap2)) is @$gp, 2, 'coverage tests for _get_parser in scalar context... and we got the right number of parsers'; -isa_ok( $_, 'TAP::Parser' ) foreach (@$gp); +isa_ok( $_, 'TAP::Parser' ) for (@$gp); # _get_parsers # todo_failed - this is a deprecated method, so it (and these tests) diff --git a/cpan/Test-Harness/t/bailout.t b/cpan/Test-Harness/t/bailout.t index e10b133e0f..e10b133e0f 100644..100755 --- a/cpan/Test-Harness/t/bailout.t +++ b/cpan/Test-Harness/t/bailout.t diff --git a/cpan/Test-Harness/t/base.t b/cpan/Test-Harness/t/base.t index 4fee54844e..dd71a0ca50 100644 --- a/cpan/Test-Harness/t/base.t +++ b/cpan/Test-Harness/t/base.t @@ -13,7 +13,7 @@ use TAP::Base; can_ok 'TAP::Base', 'new'; my $base = TAP::Base->new(); isa_ok $base, 'TAP::Base', 'object of correct type'; - foreach my $method (qw(callback _croak _callback_for _initialize)) { + for my $method (qw(callback _croak _callback_for _initialize)) { can_ok $base, $method; } diff --git a/cpan/Test-Harness/t/callbacks.t b/cpan/Test-Harness/t/callbacks.t index 18c6f0d15e..ee52092850 100644 --- a/cpan/Test-Harness/t/callbacks.t +++ b/cpan/Test-Harness/t/callbacks.t @@ -6,7 +6,7 @@ use lib 't/lib'; use Test::More tests => 10; use TAP::Parser; -use TAP::Parser::IteratorFactory; +use TAP::Parser::Iterator::Array; my $tap = <<'END_TAP'; 1..5 @@ -36,10 +36,9 @@ my %callbacks = ( } ); -my $factory = TAP::Parser::IteratorFactory->new; -my $stream = $factory->make_iterator( [ split /\n/ => $tap ] ); -my $parser = TAP::Parser->new( - { stream => $stream, +my $iterator = TAP::Parser::Iterator::Array->new( [ split /\n/ => $tap ] ); +my $parser = TAP::Parser->new( + { iterator => $iterator, callbacks => \%callbacks, } ); @@ -79,9 +78,9 @@ my $end = 0; }, ); -$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); +$iterator = TAP::Parser::Iterator::Array->new( [ split /\n/ => $tap ] ); $parser = TAP::Parser->new( - { stream => $stream, + { iterator => $iterator, callbacks => \%callbacks, } ); @@ -104,10 +103,10 @@ is $end, 1, 'EOF callback correctly called'; ELSES => sub { }, ); -$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); +$iterator = TAP::Parser::Iterator::Array->new( [ split /\n/ => $tap ] ); eval { $parser = TAP::Parser->new( - { stream => $stream, + { iterator => $iterator, callbacks => \%callbacks, } ); diff --git a/cpan/Test-Harness/t/compat/failure.t b/cpan/Test-Harness/t/compat/failure.t index 2f80e57884..d199b7b67f 100644 --- a/cpan/Test-Harness/t/compat/failure.t +++ b/cpan/Test-Harness/t/compat/failure.t @@ -19,8 +19,18 @@ use Test::Harness; return sub { $died = 1 } } - my $curdir = File::Spec->curdir; - my $sample_tests = File::Spec->catdir( $curdir, 't', 'sample-tests' ); + my $sample_tests; + if ( $ENV{PERL_CORE} ) { + my $updir = File::Spec->updir; + $sample_tests = File::Spec->catdir( + $updir, 'ext', 'Test-Harness', 't', + 'sample-tests' + ); + } + else { + my $curdir = File::Spec->curdir; + $sample_tests = File::Spec->catdir( $curdir, 't', 'sample-tests' ); + } { local $SIG{__DIE__} = prepare_for_death(); diff --git a/cpan/Test-Harness/t/compat/inc_taint.t b/cpan/Test-Harness/t/compat/inc_taint.t index 3bd86b4108..b0917dbb99 100644 --- a/cpan/Test-Harness/t/compat/inc_taint.t +++ b/cpan/Test-Harness/t/compat/inc_taint.t @@ -1,6 +1,14 @@ #!/usr/bin/perl -w -use lib 't/lib'; +BEGIN { + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + use lib 't/lib'; + } +} use strict; @@ -25,7 +33,11 @@ sub _all_ok { tie *NULL, 'Dev::Null' or die $!; select NULL; my ( $tot, $failed ) = Test::Harness::execute_tests( - tests => ['t/sample-tests/inc_taint'] + tests => [ + $ENV{PERL_CORE} + ? '../ext/Test-Harness/t/sample-tests/inc_taint' + : 't/sample-tests/inc_taint' + ] ); select STDOUT; diff --git a/cpan/Test-Harness/t/compat/subclass.t b/cpan/Test-Harness/t/compat/subclass.t new file mode 100644 index 0000000000..0b66b5ac13 --- /dev/null +++ b/cpan/Test-Harness/t/compat/subclass.t @@ -0,0 +1,38 @@ +#!/usr/bin/perl -w + +# Test that HARNESS_SUBCLASS env var is honoured. + +use strict; +use lib 't/lib'; + +use Test::More ( + $^O eq 'VMS' + ? ( skip_all => 'VMS' ) + : ( tests => 1 ) +); + +use Test::Harness; + +my $test_template = <<'END'; +#!/usr/bin/perl + +use Test::More tests => 1; + +is $ENV{HARNESS_IS_SUBCLASS}, 'TAP::Harness::TestSubclass'; +END + +my $tempfile = "_check_subclass_t.tmp"; +open TEST, ">$tempfile"; +print TEST $test_template; +close TEST; + +END { unlink $tempfile; } + +{ + local $ENV{HARNESS_SUBCLASS} = 'TAP::Harness::TestSubclass'; + my ( $tot, $failed ) + = Test::Harness::execute_tests( tests => [$tempfile] ); + is $tot->{bad}, 0; +} + +1; diff --git a/cpan/Test-Harness/t/compat/test-harness-compat.t b/cpan/Test-Harness/t/compat/test-harness-compat.t index cae9a54333..0009df16f8 100644 --- a/cpan/Test-Harness/t/compat/test-harness-compat.t +++ b/cpan/Test-Harness/t/compat/test-harness-compat.t @@ -1,7 +1,13 @@ #!/usr/bin/perl -w BEGIN { - unshift @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } + else { + unshift @INC, 't/lib'; + } } use strict; @@ -15,7 +21,8 @@ use Test::Harness qw(execute_tests); # unset this global when self-testing ('testcover' and etc issue) local $ENV{HARNESS_PERL_SWITCHES}; -my $TEST_DIR = 't/sample-tests'; +my $TEST_DIR + = $ENV{PERL_CORE} ? '../ext/Test-Harness/t/sample-tests' : 't/sample-tests'; { diff --git a/cpan/Test-Harness/t/file.t b/cpan/Test-Harness/t/file.t index f97d1aadd0..40793c3d42 100644 --- a/cpan/Test-Harness/t/file.t +++ b/cpan/Test-Harness/t/file.t @@ -1,7 +1,13 @@ #!/usr/bin/perl -w BEGIN { - unshift @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + unshift @INC, 't/lib'; + } } use strict; @@ -12,8 +18,10 @@ use TAP::Harness; my $HARNESS = 'TAP::Harness'; -my $source_tests = 't/source_tests'; -my $sample_tests = 't/sample-tests'; +my $source_tests + = $ENV{PERL_CORE} ? '../ext/Test-Harness/t/source_tests' : 't/source_tests'; +my $sample_tests + = $ENV{PERL_CORE} ? '../ext/Test-Harness/t/sample-tests' : 't/sample-tests'; plan tests => 56; diff --git a/cpan/Test-Harness/t/glob-to-regexp.t b/cpan/Test-Harness/t/glob-to-regexp.t index 493daab307..54b7e264fc 100644 --- a/cpan/Test-Harness/t/glob-to-regexp.t +++ b/cpan/Test-Harness/t/glob-to-regexp.t @@ -15,7 +15,7 @@ while (<DATA>) { plan tests => scalar @tests; -foreach (@tests) { +for (@tests) { my ( $glob, $pattern, $name ) = @$_; is( TAP::Parser::Scheduler->_glob_to_regexp($glob), $pattern, defined $name ? "$glob -- $name" : $glob diff --git a/cpan/Test-Harness/t/grammar.t b/cpan/Test-Harness/t/grammar.t index b74fc8ba65..e94c995ffd 100644 --- a/cpan/Test-Harness/t/grammar.t +++ b/cpan/Test-Harness/t/grammar.t @@ -3,7 +3,13 @@ use strict; BEGIN { - unshift @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + unshift @INC, 't/lib'; + } } use Test::More tests => 94; @@ -14,8 +20,8 @@ use TAP::Parser::Iterator::Array; my $GRAMMAR = 'TAP::Parser::Grammar'; -# Array based stream that we can push items in to -package SS; +# Array based iterator that we can push items in to +package IT; sub new { my $class = shift; @@ -36,10 +42,10 @@ sub handle_unicode { } package main; -my $stream = SS->new; -my $parser = EmptyParser->new; +my $iterator = IT->new; +my $parser = EmptyParser->new; can_ok $GRAMMAR, 'new'; -my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } ); +my $grammar = $GRAMMAR->new( { iterator => $iterator, parser => $parser } ); isa_ok $grammar, $GRAMMAR, '... and the object it returns'; # Note: all methods are actually class methods. See the docs for the reason @@ -63,7 +69,7 @@ can_ok $grammar, 'syntax_for'; can_ok $grammar, 'handler_for'; my ( %syntax_for, %handler_for ); -foreach my $type (@types) { +for my $type (@types) { ok $syntax_for{$type} = $grammar->syntax_for($type), '... and calling syntax_for() with a type name should succeed'; cmp_ok ref $syntax_for{$type}, 'eq', 'Regexp', @@ -96,7 +102,7 @@ is_deeply $plan_token, $expected, '... and it should contain the correct data'; can_ok $grammar, 'tokenize'; -$stream->put($plan); +$iterator->put($plan); ok my $token = $grammar->tokenize, '... and calling it with data should return a token'; is_deeply $token, $expected, @@ -122,7 +128,7 @@ $expected = { is_deeply $plan_token, $expected, '... and it should contain the correct data'; -$stream->put($plan); +$iterator->put($plan); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; is_deeply $token, $expected, @@ -149,7 +155,7 @@ $expected = { is_deeply $plan_token, $expected, '... and it should contain the correct data'; -$stream->put($plan); +$iterator->put($plan); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; is_deeply $token, $expected, @@ -167,7 +173,7 @@ my $bailout = 'Bail out!'; like $bailout, $syntax_for{'bailout'}, 'Bail out! should match a bailout syntax'; -$stream->put($bailout); +$iterator->put($bailout); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { @@ -182,7 +188,7 @@ $bailout = 'Bail out! some explanation'; like $bailout, $syntax_for{'bailout'}, 'Bail out! should match a bailout syntax'; -$stream->put($bailout); +$iterator->put($bailout); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { @@ -199,7 +205,7 @@ my $comment = '# this is a comment'; like $comment, $syntax_for{'comment'}, 'Comments should match the comment syntax'; -$stream->put($comment); +$iterator->put($comment); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; $expected = { @@ -215,7 +221,7 @@ is_deeply $token, $expected, my $test = 'ok 1 this is a test'; like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; -$stream->put($test); +$iterator->put($test); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; @@ -236,7 +242,7 @@ is_deeply $token, $expected, $test = 'not ok 2 this is a test # TODO whee!'; like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; -$stream->put($test); +$iterator->put($test); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; @@ -257,7 +263,7 @@ is_deeply $token, $expected, '... and the TODO should be parsed'; $test = 'ok 22 this is a test \# TODO whee!'; like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; -$stream->put($test); +$iterator->put($test); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; @@ -278,7 +284,7 @@ is_deeply $token, $expected, my $pragma = 'pragma +strict'; like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax'; -$stream->put($pragma); +$iterator->put($pragma); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; @@ -294,7 +300,7 @@ is_deeply $token, $expected, $pragma = 'pragma +strict,-foo'; like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax'; -$stream->put($pragma); +$iterator->put($pragma); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; @@ -310,7 +316,7 @@ is_deeply $token, $expected, $pragma = 'pragma +strict , -foo '; like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax'; -$stream->put($pragma); +$iterator->put($pragma); ok $token = $grammar->tokenize, '... and calling it with data should return a token'; @@ -346,13 +352,14 @@ is_deeply $token, $expected, # tokenize { - my $stream = SS->new; - my $parser = EmptyParser->new; - my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } ); + my $iterator = IT->new; + my $parser = EmptyParser->new; + my $grammar + = $GRAMMAR->new( { iterator => $iterator, parser => $parser } ); my $plan = ''; - $stream->put($plan); + $iterator->put($plan); my $result = $grammar->tokenize(); @@ -390,9 +397,10 @@ is_deeply $token, $expected, # _make_yaml_token { - my $stream = SS->new; - my $parser = EmptyParser->new; - my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } ); + my $iterator = IT->new; + my $parser = EmptyParser->new; + my $grammar + = $GRAMMAR->new( { iterator => $iterator, parser => $parser } ); $grammar->set_version(13); @@ -419,7 +427,7 @@ is_deeply $token, $expected, my $iter = iter($yaml); while ( my $line = $iter->() ) { - $stream->put($line); + $iterator->put($line); } # pad == ' ', marker == '--- ' diff --git a/cpan/Test-Harness/t/harness-bailout.t b/cpan/Test-Harness/t/harness-bailout.t index fd1dc35669..0ee8a793d6 100644 --- a/cpan/Test-Harness/t/harness-bailout.t +++ b/cpan/Test-Harness/t/harness-bailout.t @@ -35,6 +35,10 @@ for my $test (@jobs) { $harness->runtests( File::Spec->catfile( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir, 'ext', 'Test-Harness' ) + : () + ), 't', 'sample-tests', 'bailout' diff --git a/cpan/Test-Harness/t/harness-subclass.t b/cpan/Test-Harness/t/harness-subclass.t index c6b46daa21..c7d30c88e7 100644 --- a/cpan/Test-Harness/t/harness-subclass.t +++ b/cpan/Test-Harness/t/harness-subclass.t @@ -1,7 +1,13 @@ #!/usr/bin/perl -w BEGIN { - unshift @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + unshift @INC, 't/lib'; + } } use strict; @@ -47,6 +53,10 @@ for my $class ( values %class_map ) { my $aggregate = $harness->runtests( File::Spec->catfile( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir, 'ext', 'Test-Harness' ) + : () + ), 't', 'sample-tests', 'simple' diff --git a/cpan/Test-Harness/t/harness.t b/cpan/Test-Harness/t/harness.t index 3643f576f3..6c5c1d19a0 100644 --- a/cpan/Test-Harness/t/harness.t +++ b/cpan/Test-Harness/t/harness.t @@ -1,7 +1,13 @@ #!/usr/bin/perl -w BEGIN { - unshift @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + unshift @INC, 't/lib'; + } } use strict; @@ -13,10 +19,12 @@ use TAP::Harness; my $HARNESS = 'TAP::Harness'; -my $source_tests = 't/source_tests'; -my $sample_tests = 't/sample-tests'; +my $source_tests + = $ENV{PERL_CORE} ? '../ext/Test-Harness/t/source_tests' : 't/source_tests'; +my $sample_tests + = $ENV{PERL_CORE} ? '../ext/Test-Harness/t/sample-tests' : 't/sample-tests'; -plan tests => 119; +plan tests => 128; # note that this test will always pass when run through 'prove' ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set'; @@ -56,9 +64,9 @@ is $@, '', '... and calling it with non-existent libs is fine'; ok my $harness = $HARNESS->new, 'Calling new() without arguments should succeed'; -foreach my $test_args ( get_arg_sets() ) { +for my $test_args ( get_arg_sets() ) { my %args = %$test_args; - foreach my $key ( sort keys %args ) { + for my $key ( sort keys %args ) { $args{$key} = $args{$key}{in}; } ok my $harness = $HARNESS->new( {%args} ), @@ -520,6 +528,8 @@ foreach my $test_args ( get_arg_sets() ) { SKIP: { my $cat = '/bin/cat'; + + # TODO: use TYPE on win32? unless ( -e $cat ) { skip "no '$cat'", 2; } @@ -535,7 +545,9 @@ SKIP: { eval { _runtests( $harness, - 't/data/catme.1' + $ENV{PERL_CORE} + ? '../ext/Test-Harness/t/data/catme.1' + : 't/data/catme.1' ); }; @@ -583,7 +595,9 @@ SKIP: { exec => sub { return [ $cat, - 't/data/catme.1' + $ENV{PERL_CORE} + ? '../ext/Test-Harness/t/data/catme.1' + : 't/data/catme.1' ]; }, } @@ -630,7 +644,10 @@ SKIP: { { verbosity => -2, stdout => $capture, exec => sub { - open my $fh, 't/data/catme.1'; + open my $fh, + $ENV{PERL_CORE} + ? '../ext/Test-Harness/t/data/catme.1' + : 't/data/catme.1'; return $fh; }, } @@ -674,6 +691,66 @@ SKIP: { ); } +# customize default File source +{ + my $capture = IO::c55Capture->new_handle; + my $harness = TAP::Harness->new( + { verbosity => -2, + stdout => $capture, + sources => { + File => { extensions => ['.1'] }, + }, + } + ); + + _runtests( $harness, "$source_tests/source.1" ); + + my @output = tied($$capture)->dump; + my $status = pop @output; + like $status, qr{^Result: PASS$}, + 'customized File source has correct status line'; + pop @output; # get rid of summary line + my $answer = pop @output; + is( $answer, "All tests successful.\n", '... all tests passed' ); +} + +# load a custom source +{ + my $capture = IO::c55Capture->new_handle; + my $harness = TAP::Harness->new( + { verbosity => -2, + stdout => $capture, + sources => { + MyFileSourceHandler => { extensions => ['.1'] }, + }, + } + ); + + my $source_test = "$source_tests/source.1"; + eval { _runtests( $harness, "$source_tests/source.1" ); }; + my $e = $@; + ok( !$e, 'no error on load custom source' ) || diag($e); + + no warnings 'once'; + can_ok( 'MyFileSourceHandler', 'make_iterator' ); + ok( $MyFileSourceHandler::CAN_HANDLE, + '... MyFileSourceHandler->can_handle was called' + ); + ok( $MyFileSourceHandler::MAKE_ITER, + '... MyFileSourceHandler->make_iterator was called' + ); + + my $raw_source = eval { ${ $MyFileSourceHandler::LAST_SOURCE->raw } }; + is( $raw_source, $source_test, '... used the right source' ); + + my @output = tied($$capture)->dump; + my $status = pop(@output) || ''; + like $status, qr{^Result: PASS$}, '... and test has correct status line'; + pop @output; # get rid of summary line + my $answer = pop @output; + is( $answer, "All tests successful.\n", '... all tests passed' ); +} + sub trim { $_[0] =~ s/^\s+|\s+$//g; return $_[0]; @@ -901,6 +978,10 @@ sub _runtests { # coverage tests for the basically untested T::H::_open_spool my @spool = ( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test-Harness' ) + : () + ), ( 't', 'spool' ) ); $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool); diff --git a/cpan/Test-Harness/t/iterator_factory.t b/cpan/Test-Harness/t/iterator_factory.t new file mode 100644 index 0000000000..668045c7a8 --- /dev/null +++ b/cpan/Test-Harness/t/iterator_factory.t @@ -0,0 +1,162 @@ +#!/usr/bin/perl -w +# +# Tests for TAP::Parser::IteratorFactory & source detection +## + +BEGIN { + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +use Test::More tests => 42; + +use IO::File; +use File::Spec; +use TAP::Parser::Source; +use TAP::Parser::IteratorFactory; + +# Test generic API... +{ + can_ok 'TAP::Parser::IteratorFactory', 'new'; + my $sf = TAP::Parser::IteratorFactory->new; + isa_ok $sf, 'TAP::Parser::IteratorFactory'; + can_ok $sf, 'config'; + can_ok $sf, 'handlers'; + can_ok $sf, 'detect_source'; + can_ok $sf, 'make_iterator'; + can_ok $sf, 'register_handler'; + + # Set config + eval { $sf->config('bad config') }; + my $e = $@; + like $e, qr/\QArgument to &config must be a hash reference/, + '... and calling config with bad config should fail'; + + my $config = { MySourceHandler => { foo => 'bar' } }; + is( $sf->config($config), $sf, '... and set config works' ); + + # Load/Register a handler + $sf = TAP::Parser::IteratorFactory->new( + { MySourceHandler => { accept => 'known-source' } } ); + can_ok( 'MySourceHandler', 'can_handle' ); + is_deeply( $sf->handlers, ['MySourceHandler'], '... was registered' ); + + # Known source should pass + { + my $source = TAP::Parser::Source->new->raw( \'known-source' ); + my $iterator = eval { $sf->make_iterator($source) }; + my $error = $@; + ok( !$error, 'make_iterator with known source doesnt fail' ); + diag($error) if $error; + isa_ok( $iterator, 'MyIterator', '... and iterator class' ); + } + + # No known source should fail + { + my $source = TAP::Parser::Source->new->raw( \'unknown-source' ); + my $iterator = eval { $sf->make_iterator($source) }; + my $error = $@; + ok( $error, 'make_iterator with unknown source fails' ); + like $error, qr/^Cannot detect source of 'unknown-source'/, + '... with an appropriate error message'; + } +} + +# Source detection +use_ok('TAP::Parser::SourceHandler::Executable'); +use_ok('TAP::Parser::SourceHandler::Perl'); +use_ok('TAP::Parser::SourceHandler::File'); +use_ok('TAP::Parser::SourceHandler::RawTAP'); +use_ok('TAP::Parser::SourceHandler::Handle'); + +my $test_dir = File::Spec->catdir( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test-Harness' ) + : () + ), + 't', + 'source_tests' +); + +my @sources = ( + { file => 'source.tap', + handler => 'TAP::Parser::SourceHandler::File', + iterator => 'TAP::Parser::Iterator::Stream', + }, + { file => 'source.1', + handler => 'TAP::Parser::SourceHandler::File', + config => { File => { extensions => ['.1'] } }, + iterator => 'TAP::Parser::Iterator::Stream', + }, + { file => 'source.pl', + handler => 'TAP::Parser::SourceHandler::Perl', + iterator => 'TAP::Parser::Iterator::Process', + }, + { file => 'source.t', + handler => 'TAP::Parser::SourceHandler::Perl', + iterator => 'TAP::Parser::Iterator::Process', + }, + { file => 'source', + handler => 'TAP::Parser::SourceHandler::Perl', + iterator => 'TAP::Parser::Iterator::Process', + }, + { file => 'source.sh', + handler => 'TAP::Parser::SourceHandler::Executable', + iterator => 'TAP::Parser::Iterator::Process', + }, + { file => 'source.bat', + handler => 'TAP::Parser::SourceHandler::Executable', + iterator => 'TAP::Parser::Iterator::Process', + }, + { name => 'raw tap string', + source => "0..1\nok 1 - raw tap\n", + handler => 'TAP::Parser::SourceHandler::RawTAP', + iterator => 'TAP::Parser::Iterator::Array', + }, + { name => 'raw tap array', + source => [ "0..1\n", "ok 1 - raw tap\n" ], + handler => 'TAP::Parser::SourceHandler::RawTAP', + iterator => 'TAP::Parser::Iterator::Array', + }, + { source => \*__DATA__, + handler => 'TAP::Parser::SourceHandler::Handle', + iterator => 'TAP::Parser::Iterator::Stream', + }, + { source => IO::File->new('-'), + handler => 'TAP::Parser::SourceHandler::Handle', + iterator => 'TAP::Parser::Iterator::Stream', + }, +); + +for my $test (@sources) { + local $TODO = $test->{TODO}; + if ( $test->{file} ) { + $test->{name} = $test->{file}; + $test->{source} = File::Spec->catfile( $test_dir, $test->{file} ); + } + + my $name = $test->{name} || substr( $test->{source}, 0, 10 ); + my $sf + = TAP::Parser::IteratorFactory->new( $test->{config} )->_testing(1); + + my $raw = $test->{source}; + my $source = TAP::Parser::Source->new->raw( ref($raw) ? $raw : \$raw ); + my $iterator = eval { $sf->make_iterator($source) }; + my $error = $@; + ok( !$error, "$name: no error on make_iterator" ); + diag($error) if $error; + + # isa_ok( $iterator, $test->{iterator}, $name ); + is( $sf->_last_handler, $test->{handler}, $name ); +} + +__END__ +0..1 +ok 1 - TAP in the __DATA__ handle diff --git a/cpan/Test-Harness/t/iterators.t b/cpan/Test-Harness/t/iterators.t index d190be9289..2b6028e0a2 100644 --- a/cpan/Test-Harness/t/iterators.t +++ b/cpan/Test-Harness/t/iterators.t @@ -7,7 +7,7 @@ use Test::More tests => 76; use File::Spec; use TAP::Parser; -use TAP::Parser::IteratorFactory; +use TAP::Parser::Iterator::Array; use Config; sub array_ref_from { @@ -42,6 +42,10 @@ my @schedule = ( command => [ $^X, File::Spec->catfile( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test-Harness' ) + : () + ), 't', 'sample-tests', 'out_err_mix' @@ -82,7 +86,6 @@ sub _can_open3 { return $Config{d_fork}; } -my $factory = TAP::Parser::IteratorFactory->new; for my $test (@schedule) { SKIP: { my $name = $test->{name}; @@ -91,37 +94,41 @@ for my $test (@schedule) { my $subclass = $test->{subclass}; my $source = $test->{source}; my $class = $test->{class}; - my $iter + my $iterator = $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', + : make_iterator($source); + + ok $iterator, "$name: We should be able to create a new iterator"; + isa_ok $iterator, 'TAP::Parser::Iterator', '... and the object it returns'; - isa_ok $iter, $subclass, '... and the object it returns'; + isa_ok $iterator, $subclass, '... and the object it returns'; - can_ok $iter, 'exit'; - ok !defined $iter->exit, + can_ok $iterator, 'exit'; + ok !defined $iterator->exit, "$name: ... and it should be undef before we are done ($subclass)"; - can_ok $iter, 'next'; - is $iter->next, 'one', "$name: next() should return the first result"; + can_ok $iterator, 'next'; + is $iterator->next, 'one', + "$name: next() should return the first result"; - is $iter->next, 'two', + is $iterator->next, 'two', "$name: next() should return the second result"; - is $iter->next, '', "$name: next() should return the third result"; + is $iterator->next, '', + "$name: next() should return the third result"; - is $iter->next, 'three', + is $iterator->next, 'three', "$name: next() should return the fourth result"; - ok !defined $iter->next, + ok !defined $iterator->next, "$name: next() should return undef after it is empty"; - is $iter->exit, 0, + is $iterator->exit, 0, "$name: ... and exit should now return 0 ($subclass)"; - is $iter->wait, 0, "$name: wait should also now return 0 ($subclass)"; + is $iterator->wait, 0, + "$name: wait should also now return 0 ($subclass)"; if ( my $after = $test->{after} ) { $after->(); @@ -133,16 +140,15 @@ for my $test (@schedule) { # coverage tests for the ctor - my $stream = $factory->make_iterator( IO::Handle->new ); + my $iterator = make_iterator( IO::Handle->new ); - isa_ok $stream, 'TAP::Parser::Iterator::Stream'; + isa_ok $iterator, 'TAP::Parser::Iterator::Stream'; my @die; eval { local $SIG{__DIE__} = sub { push @die, @_ }; - - $factory->make_iterator( \1 ); # a ref to a scalar + make_iterator( \1 ); # a ref to a scalar }; is @die, 1, 'coverage of error case'; @@ -155,23 +161,23 @@ for my $test (@schedule) { # coverage test for VMS case - my $stream = $factory->make_iterator( + my $iterator = make_iterator( [ 'not ', 'ok 1 - I hate VMS', ] ); - is $stream->next, 'not ok 1 - I hate VMS', + is $iterator->next, 'not ok 1 - I hate VMS', 'coverage of VMS line-splitting case'; # coverage test for VMS case - nothing after 'not' - $stream = $factory->make_iterator( + $iterator = make_iterator( [ 'not ', ] ); - is $stream->next, 'not ', '...and we find "not" by itself'; + is $iterator->next, 'not ', '...and we find "not" by itself'; } SKIP: { @@ -183,8 +189,7 @@ SKIP: { eval { local $SIG{__DIE__} = sub { push @die, @_ }; - - $factory->make_iterator( {} ); + make_iterator( {} ); }; is @die, 1, 'coverage testing for TPI::Process'; @@ -192,7 +197,7 @@ SKIP: { like pop @die, qr/Must supply a command to execute/, '...and we died as expected'; - my $parser = $factory->make_iterator( + my $parser = make_iterator( { command => [ $^X, File::Spec->catfile( 't', 'sample-tests', 'out_err_mix' ) @@ -208,6 +213,24 @@ SKIP: { # bug which frequently throws an error here otherwise. $parser->next; } + +sub make_iterator { + my $thing = shift; + my $ref = ref $thing; + if ( $ref eq 'GLOB' || UNIVERSAL::isa( $ref, '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"; + } +} + __DATA__ one two diff --git a/cpan/Test-Harness/t/lib/EmptyParser.pm b/cpan/Test-Harness/t/lib/EmptyParser.pm index 2f7ec2428e..76f9a7d2f4 100644 --- a/cpan/Test-Harness/t/lib/EmptyParser.pm +++ b/cpan/Test-Harness/t/lib/EmptyParser.pm @@ -15,11 +15,7 @@ sub _initialize { sub _set_defaults { my $self = shift; - for my $key ( - qw( source_class perl_source_class grammar_class - iterator_factory_class result_factory_class ) - ) - { + for my $key (qw( grammar_class result_factory_class )) { my $default_method = "_default_$key"; $self->$key( $self->$default_method() ); } diff --git a/cpan/Test-Harness/t/lib/MyCustom.pm b/cpan/Test-Harness/t/lib/MyCustom.pm index 2402312edc..c24013db90 100644 --- a/cpan/Test-Harness/t/lib/MyCustom.pm +++ b/cpan/Test-Harness/t/lib/MyCustom.pm @@ -5,7 +5,7 @@ use strict; sub custom { my $self = shift; - $main::CUSTOM{ ref($self) }++; + $main::CUSTOM{ ref($self) || $self }++; return $self; } diff --git a/cpan/Test-Harness/t/lib/MyFileSourceHandler.pm b/cpan/Test-Harness/t/lib/MyFileSourceHandler.pm new file mode 100644 index 0000000000..d9b66c65d5 --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyFileSourceHandler.pm @@ -0,0 +1,35 @@ +# subclass for testing TAP::Harness custom sources + +package MyFileSourceHandler; + +use strict; +use vars qw( @ISA $LAST_OBJ $CAN_HANDLE $MAKE_ITER $LAST_SOURCE ); + +use MyCustom; +use TAP::Parser::IteratorFactory; +use TAP::Parser::SourceHandler::File; + +@ISA = qw( TAP::Parser::SourceHandler::File MyCustom ); +$LAST_OBJ = undef; +$CAN_HANDLE = undef; +$MAKE_ITER = undef; +$LAST_SOURCE = undef; + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +sub can_handle { + my $class = shift; + $class->SUPER::can_handle(@_); + $CAN_HANDLE++; + return $class; +} + +sub make_iterator { + my ( $class, $source ) = @_; + my $iter = $class->SUPER::make_iterator($source); + $MAKE_ITER++; + $LAST_SOURCE = $source; + return $iter; +} + +1; diff --git a/cpan/Test-Harness/t/lib/MyIteratorFactory.pm b/cpan/Test-Harness/t/lib/MyIteratorFactory.pm deleted file mode 100644 index d8c3269cda..0000000000 --- a/cpan/Test-Harness/t/lib/MyIteratorFactory.pm +++ /dev/null @@ -1,19 +0,0 @@ -# subclass for testing customizing & subclassing - -package MyIteratorFactory; - -use strict; -use vars '@ISA'; - -use MyCustom; -use MyIterator; -use TAP::Parser::IteratorFactory; - -@ISA = qw( TAP::Parser::IteratorFactory MyCustom ); - -sub make_iterator { - my $class = shift; - return MyIterator->new(@_); -} - -1; diff --git a/cpan/Test-Harness/t/lib/MyPerlSource.pm b/cpan/Test-Harness/t/lib/MyPerlSource.pm deleted file mode 100644 index 6193db97df..0000000000 --- a/cpan/Test-Harness/t/lib/MyPerlSource.pm +++ /dev/null @@ -1,27 +0,0 @@ -# subclass for testing customizing & subclassing - -package MyPerlSource; - -use strict; -use vars '@ISA'; - -use MyCustom; -use TAP::Parser::Source::Perl; - -@ISA = qw( TAP::Parser::Source::Perl MyCustom ); - -sub _initialize { - my $self = shift; - $self->SUPER::_initialize(@_); - $main::INIT{ ref($self) }++; - $self->{initialized} = 1; - return $self; -} - -sub source { - my $self = shift; - return $self->SUPER::source(@_); -} - -1; - diff --git a/cpan/Test-Harness/t/lib/MyPerlSourceHandler.pm b/cpan/Test-Harness/t/lib/MyPerlSourceHandler.pm new file mode 100644 index 0000000000..e5a34bedb6 --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyPerlSourceHandler.pm @@ -0,0 +1,24 @@ +# subclass for testing customizing & subclassing + +package MyPerlSourceHandler; + +use strict; +use vars '@ISA'; + +use MyCustom; +use TAP::Parser::IteratorFactory; +use TAP::Parser::SourceHandler::Perl; + +@ISA = qw( TAP::Parser::SourceHandler::Perl MyCustom ); + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +sub can_handle { + my $class = shift; + my $vote = $class->SUPER::can_handle(@_); + $vote += 0.1 if $vote > 0; # steal the Perl handler's vote + return $vote; +} + +1; + diff --git a/cpan/Test-Harness/t/lib/MyShebangger.pm b/cpan/Test-Harness/t/lib/MyShebangger.pm new file mode 100644 index 0000000000..074a2e187a --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyShebangger.pm @@ -0,0 +1,94 @@ +package MyShebangger; + +use strict; +use warnings; + +use Config; + +=head1 NAME + +MyShebangger - Encapsulate EUMM / MB shebang magic + +=item fix_shebang + + fix_shebang($file_in, $file_out); + +Inserts the sharpbang or equivalent magic number at the start of a file. + +=cut + +# stolen from ExtUtils::MakeMaker which said: +# stolen from the pink Camel book, more or less +sub fix_shebang { + my ( $file_in, $file_out ) = @_; + + my ($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/; + + open my $fixin, '<', $file_in or die "Can't process '$file_in': $!"; + local $/ = "\n"; + chomp( my $line = <$fixin> ); + + die "$file_in doesn't have a shebang line" + unless $line =~ s/^\s*\#!\s*//; + + # Now figure out the interpreter name. + my ( $cmd, $arg ) = split ' ', $line, 2; + $cmd =~ s!^.*/!!; + + my $interpreter; + + die "$file_in is not perl" + unless $cmd =~ m{^perl(?:\z|[^a-z])}; + + if ( $Config{startperl} =~ m,^\#!.*/perl, ) { + $interpreter = $Config{startperl}; + $interpreter =~ s,^\#!,,; + } + else { + $interpreter = $Config{perlpath}; + } + + die "Can't figure out which interpreter to use." + unless defined $interpreter; + + # Figure out how to invoke interpreter on this machine. + my $shb = ''; + + # this is probably value-free on DOSISH platforms + my $shb_line = join ' ', grep defined, $interpreter, $arg; + $shb .= "$Config{'sharpbang'}$shb_line\n" + if $does_shbang; + $shb .= qq{ +eval 'exec $shb_line -S \$0 \${1+"\$\@"}' + if 0; # not running under some shell +} unless $^O eq 'MSWin32'; # this won't work on win32, so don't + + open my $fixout, ">", "$file_out" + or die "Can't create new $file_out: $!\n"; + + # Print out the new #! line (or equivalent). + local $\; + local $/; + print $fixout $shb, <$fixin>; + close $fixin; + close $fixout; + + system("$Config{'eunicefix'} $file_out") if $Config{'eunicefix'} ne ':'; + chmod 0755, $file_out; # ignore failure +} + +{ + my @cleanup = (); + my $seq = 1; + END { unlink @cleanup } + + sub make_perl_executable { + my $file = shift; + my $tmp_file = "${file}_${$}_$seq.pl"; + $seq++; + fix_shebang( $file, $tmp_file ); + push @cleanup, $tmp_file; + return $tmp_file; + } +} +1; diff --git a/cpan/Test-Harness/t/lib/MySource.pm b/cpan/Test-Harness/t/lib/MySource.pm deleted file mode 100644 index 5e41b829ae..0000000000 --- a/cpan/Test-Harness/t/lib/MySource.pm +++ /dev/null @@ -1,34 +0,0 @@ -# subclass for testing customizing & subclassing - -package MySource; - -use strict; -use vars '@ISA'; - -use MyCustom; -use TAP::Parser::Source; - -@ISA = qw( TAP::Parser::Source MyCustom ); - -sub _initialize { - my $self = shift; - $self->SUPER::_initialize(@_); - $main::INIT{ ref($self) }++; - $self->{initialized} = 1; - return $self; -} - -sub source { - my $self = shift; - return $self->SUPER::source(@_); -} - -sub get_stream { - my $self = shift; - my $stream = $self->SUPER::get_stream(@_); - - # re-bless it: - bless $stream, 'MyIterator'; -} - -1; diff --git a/cpan/Test-Harness/t/lib/MySourceHandler.pm b/cpan/Test-Harness/t/lib/MySourceHandler.pm new file mode 100644 index 0000000000..67cbee016f --- /dev/null +++ b/cpan/Test-Harness/t/lib/MySourceHandler.pm @@ -0,0 +1,39 @@ +# subclass for testing customizing & subclassing + +package MySourceHandler; + +use strict; +use vars '@ISA'; + +use MyCustom; +use MyIterator; +use TAP::Parser::SourceHandler; +use TAP::Parser::IteratorFactory; + +#@ISA = qw( TAP::Parser::SourceHandler MyCustom ); +@ISA = qw( MyCustom ); + +TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); + +sub can_handle { + my ( $class, $source ) = @_; + my $meta = $source->meta; + my $config = $source->config_for($class); + + if ( $config->{accept_all} ) { + return 1; + } + elsif ( my $accept = $config->{accept} ) { + return 0 unless $meta->{is_scalar}; + return 1 if ${ $source->raw } eq $accept; + } + return 0; +} + +sub make_iterator { + my ( $class, $source ) = @_; + $class->custom; + return MyIterator->new( [ $source->raw ] ); +} + +1; diff --git a/cpan/Test-Harness/t/lib/TAP/Harness/TestSubclass.pm b/cpan/Test-Harness/t/lib/TAP/Harness/TestSubclass.pm new file mode 100644 index 0000000000..5a449222ad --- /dev/null +++ b/cpan/Test-Harness/t/lib/TAP/Harness/TestSubclass.pm @@ -0,0 +1,10 @@ +package TAP::Harness::TestSubclass; +use strict; +use base 'TAP::Harness'; + +sub aggregate_tests { + local $ENV{HARNESS_IS_SUBCLASS} = __PACKAGE__; + $_[0]->SUPER::aggregate_tests; +} + +1; diff --git a/cpan/Test-Harness/t/lib/TAP/Parser/SubclassTest.pm b/cpan/Test-Harness/t/lib/TAP/Parser/SubclassTest.pm index 84becee932..8772dfd61f 100644 --- a/cpan/Test-Harness/t/lib/TAP/Parser/SubclassTest.pm +++ b/cpan/Test-Harness/t/lib/TAP/Parser/SubclassTest.pm @@ -8,25 +8,26 @@ use vars qw(@ISA); use TAP::Parser; use MyCustom; -use MySource; -use MyPerlSource; +use MySourceHandler; +use MyPerlSourceHandler; use MyGrammar; -use MyIteratorFactory; use MyResultFactory; @ISA = qw( TAP::Parser MyCustom ); -sub _default_source_class {'MySource'} -sub _default_perl_source_class {'MyPerlSource'} -sub _default_grammar_class {'MyGrammar'} -sub _default_iterator_factory_class {'MyIteratorFactory'} -sub _default_result_factory_class {'MyResultFactory'} - -sub make_source { shift->SUPER::make_source(@_)->custom } -sub make_perl_source { shift->SUPER::make_perl_source(@_)->custom } -sub make_grammar { shift->SUPER::make_grammar(@_)->custom } -sub make_iterator { shift->SUPER::make_iterator(@_)->custom } -sub make_result { shift->SUPER::make_result(@_)->custom } +sub _default_source_class {'MySourceHandler'} # deprecated +sub _default_perl_source_class {'MyPerlSourceHandler'} # deprecated +sub _default_grammar_class {'MyGrammar'} +sub _default_result_factory_class {'MyResultFactory'} + +sub make_source { shift->SUPER::make_source(@_)->custom } # deprecated + +sub make_perl_source { + shift->SUPER::make_perl_source(@_)->custom; +} # deprecated +sub make_grammar { shift->SUPER::make_grammar(@_)->custom } +sub make_iterator { shift->SUPER::make_iterator(@_)->custom } # deprecated +sub make_result { shift->SUPER::make_result(@_)->custom } sub _initialize { my $self = shift; diff --git a/cpan/Test-Harness/t/multiplexer.t b/cpan/Test-Harness/t/multiplexer.t index 649d5d161f..3598521bdf 100644 --- a/cpan/Test-Harness/t/multiplexer.t +++ b/cpan/Test-Harness/t/multiplexer.t @@ -56,6 +56,11 @@ my @schedule = ( return [ TAP::Parser->new( { source => File::Spec->catfile( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test-Harness' + ) + : () + ), 't', 'sample-tests', 'simple' @@ -77,6 +82,12 @@ my @schedule = ( return map { [ TAP::Parser->new( { source => File::Spec->catfile( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', + 'Test-Harness' + ) + : () + ), 't', 'sample-tests', 'simple' @@ -118,6 +129,12 @@ my @schedule = ( ( map { [ TAP::Parser->new( { source => File::Spec->catfile( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', + 'Test-Harness' + ) + : () + ), 't', 'sample-tests', 'simple' diff --git a/cpan/Test-Harness/t/nofork-mux.t b/cpan/Test-Harness/t/nofork-mux.t index 4f28bf8c1d..1dba20d470 100644 --- a/cpan/Test-Harness/t/nofork-mux.t +++ b/cpan/Test-Harness/t/nofork-mux.t @@ -1,10 +1,17 @@ #!/usr/bin/perl -w BEGIN { - use lib 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + use lib 't/lib'; + } } use strict; use NoFork; -require( 't/multiplexer.t' ); +require( + ( $ENV{PERL_CORE} ? '../ext/Test-Harness/' : '' ) . 't/multiplexer.t' ); diff --git a/cpan/Test-Harness/t/nofork.t b/cpan/Test-Harness/t/nofork.t index 1d8b340e1b..01375e034b 100644..100755 --- a/cpan/Test-Harness/t/nofork.t +++ b/cpan/Test-Harness/t/nofork.t @@ -3,7 +3,15 @@ # check nofork logic on systems which *can* fork() # NOTE maybe a good candidate for xt/author or something. -use lib 't/lib'; +BEGIN { + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + use lib 't/lib'; + } +} use strict; @@ -49,7 +57,8 @@ my $mod = 'TAP::Parser::Iterator::Process'; stdout => $capture, } ); - $harness->runtests( 't/sample-tests/simple' ); + $harness->runtests( ( $ENV{PERL_CORE} ? '../ext/Test-Harness/' : '' ) + . 't/sample-tests/simple' ); my @output = tied($$capture)->dump; is pop @output, "Result: PASS\n", 'status OK'; pop @output; # get rid of summary line diff --git a/cpan/Test-Harness/t/parse.t b/cpan/Test-Harness/t/parse.t index f0def28c9a..97db067da9 100644..100755 --- a/cpan/Test-Harness/t/parse.t +++ b/cpan/Test-Harness/t/parse.t @@ -2,7 +2,15 @@ use strict; -use lib 't/lib'; +BEGIN { + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + use lib 't/lib'; + } +} use Test::More tests => 294; use IO::c55Capture; @@ -10,7 +18,7 @@ use IO::c55Capture; use File::Spec; use TAP::Parser; -use TAP::Parser::IteratorFactory; +use TAP::Parser::Iterator::Array; sub _get_results { my $parser = shift; @@ -33,8 +41,6 @@ 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 @@ -343,7 +349,8 @@ END_TAP my $aref = [ split /\n/ => $tap ]; can_ok $PARSER, 'new'; -$parser = $PARSER->new( { stream => $factory->make_iterator($aref) } ); +$parser + = $PARSER->new( { iterator => TAP::Parser::Iterator::Array->new($aref) } ); isa_ok $parser, $PARSER, '... and calling it should succeed'; # results() is sane? @@ -446,7 +453,9 @@ is( scalar @results, 2, "Got two lines of TAP" ); # Check source => $filehandle can_ok $PARSER, 'new'; -open my $fh, 't/data/catme.1'; +open my $fh, $ENV{PERL_CORE} + ? '../ext/Test-Harness/t/data/catme.1' + : 't/data/catme.1'; $parser = $PARSER->new( { source => $fh } ); isa_ok $parser, $PARSER, '... and calling it should succeed'; ok @results = _get_results($parser), 'The parser should return results'; @@ -522,7 +531,7 @@ END_TAP is @die, 1, 'coverage testing for _initialize'; - like pop @die, qr/PANIC:\s+could not determine stream at/, + like pop @die, qr/PANIC:\s+could not determine iterator for input\s*at/, '...and it failed as expected'; @die = (); @@ -531,9 +540,9 @@ END_TAP local $SIG{__DIE__} = sub { push @die, @_ }; $PARSER->new( - { stream => 'stream', - tap => 'tap', - source => 'source', # only one of these is allowed + { iterator => 'iterator', + tap => 'tap', + source => 'source', # only one of these is allowed } ); }; @@ -541,7 +550,7 @@ END_TAP is @die, 1, 'coverage testing for _initialize'; like pop @die, - qr/You may only choose one of 'exec', 'stream', 'tap' or 'source'/, + qr/You may only choose one of 'exec', 'tap', 'source' or 'iterator'/, '...and it failed as expected'; } @@ -596,21 +605,25 @@ END_TAP isa_ok $parser, 'TAP::Parser'; - isa_ok $parser->_stream, 'TAP::Parser::Iterator::Array'; + isa_ok $parser->_iterator, 'TAP::Parser::Iterator::Array'; - # uncategorisable argument to source - my @die; + SKIP: { + skip 'Segfaults Perl 5.6.0' => 2 if $] <= 5.006000; - eval { - local $SIG{__DIE__} = sub { push @die, @_ }; + # uncategorisable argument to source + my @die; - $parser = TAP::Parser->new( { source => 'nosuchfile' } ); - }; + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; - is @die, 1, 'uncategorisable source'; + $parser = TAP::Parser->new( { source => 'nosuchfile' } ); + }; - like pop @die, qr/Cannot determine source for nosuchfile/, - '... and we died as expected'; + is @die, 1, 'uncategorisable source'; + + like pop @die, qr/Cannot detect source of 'nosuchfile'/, + '... and we died as expected'; + } } { @@ -619,6 +632,10 @@ END_TAP my $parser = TAP::Parser->new( { source => File::Spec->catfile( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test-Harness' ) + : () + ), 't', 'sample-tests', 'simple' @@ -628,7 +645,7 @@ END_TAP isa_ok $parser, 'TAP::Parser'; - isa_ok $parser->_stream, 'TAP::Parser::Iterator::Process'; + isa_ok $parser->_iterator, 'TAP::Parser::Iterator::Process'; # Workaround for Mac OS X problem wrt closing the iterator without # reading from it. @@ -792,7 +809,7 @@ END_TAP # we're going to bash the internals a bit (but using the API as # much as possible) to force grammar->tokenise() to fail - # firstly we'll create a stream that dies when its next_raw method is called +# firstly we'll create a iterator that dies when its next_raw method is called package TAP::Parser::Iterator::Dies; @@ -822,17 +839,17 @@ END_TAP { my $parser = TAP::Parser->new( { tap => $tap } ); - # build a dying stream - my $stream = TAP::Parser::Iterator::Dies->new; + # build a dying iterator + my $iterator = TAP::Parser::Iterator::Dies->new; - # now replace the stream - we're forced to us an T::P intenal + # now replace the iterator - we're forced to us an T::P intenal # method for this - $parser->_stream($stream); + $parser->_iterator($iterator); # build a new grammar my $grammar = TAP::Parser::Grammar->new( - { stream => $stream, - parser => $parser + { iterator => $iterator, + parser => $parser } ); @@ -858,17 +875,17 @@ END_TAP $parser->callback( 'ALL', sub { } ); - # build a dying stream - my $stream = TAP::Parser::Iterator::Dies->new; + # build a dying iterator + my $iterator = TAP::Parser::Iterator::Dies->new; - # now replace the stream - we're forced to us an T::P intenal + # now replace the iterator - we're forced to us an T::P intenal # method for this - $parser->_stream($stream); + $parser->_iterator($iterator); # build a new grammar my $grammar = TAP::Parser::Grammar->new( - { stream => $stream, - parser => $parser + { iterator => $iterator, + parser => $parser } ); diff --git a/cpan/Test-Harness/t/parser-config.t b/cpan/Test-Harness/t/parser-config.t index bd3625902d..1e0b719947 100644 --- a/cpan/Test-Harness/t/parser-config.t +++ b/cpan/Test-Harness/t/parser-config.t @@ -1,29 +1,30 @@ #!/usr/bin/perl -w BEGIN { + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { unshift @INC, 't/lib'; + } } use strict; use vars qw(%INIT %CUSTOM); -use Test::More tests => 11; +use Test::More tests => 5; use File::Spec::Functions qw( catfile updir ); use TAP::Parser; -use_ok('MySource'); -use_ok('MyPerlSource'); use_ok('MyGrammar'); -use_ok('MyIteratorFactory'); use_ok('MyResultFactory'); -my $source = catfile( 't', 'source_tests', 'source' ); +my @t_path = $ENV{PERL_CORE} ? ( updir(), 'ext', 'Test-Harness' ) : (); +my $source = catfile( @t_path, 't', 'source_tests', 'source' ); my %customize = ( - source_class => 'MySource', - perl_source_class => 'MyPerlSource', - grammar_class => 'MyGrammar', - iterator_factory_class => 'MyIteratorFactory', - result_factory_class => 'MyResultFactory', + grammar_class => 'MyGrammar', + result_factory_class => 'MyResultFactory', ); my $p = TAP::Parser->new( { source => $source, @@ -32,7 +33,7 @@ my $p = TAP::Parser->new( ); ok( $p, 'new customized parser' ); -foreach my $key ( keys %customize ) { +for my $key ( keys %customize ) { is( $p->$key(), $customize{$key}, "customized $key" ); } diff --git a/cpan/Test-Harness/t/parser-subclass.t b/cpan/Test-Harness/t/parser-subclass.t index 303c28ca27..2935722427 100644 --- a/cpan/Test-Harness/t/parser-subclass.t +++ b/cpan/Test-Harness/t/parser-subclass.t @@ -1,21 +1,29 @@ #!/usr/bin/perl -w BEGIN { - unshift @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + unshift @INC, 't/lib'; + } } use strict; use vars qw(%INIT %CUSTOM); -use Test::More tests => 24; +use Test::More tests => 14; use File::Spec::Functions qw( catfile updir ); use_ok('TAP::Parser::SubclassTest'); -# TODO: foreach my $source ( ... ) +# TODO: for my $source ( ... ) ? +my @t_path = $ENV{PERL_CORE} ? ( updir(), 'ext', 'Test-Harness' ) : (); + { # perl source %INIT = %CUSTOM = (); - my $source = catfile( 't', 'subclass_tests', 'perl_source' ); + my $source = catfile( @t_path, 't', '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 @@ -24,31 +32,19 @@ use_ok('TAP::Parser::SubclassTest'); 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->grammar_class => 'MyGrammar', 'grammar_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' ); + 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' ); @@ -68,13 +64,15 @@ SKIP: { # non-perl source %INIT = %CUSTOM = (); my $cat = '/bin/cat'; unless ( -e $cat ) { - skip "no '$cat'", 4; + skip "no '$cat'", 2; } - my $file = catfile( 't', 'data', 'catme.1' ); - my $p = TAP::Parser::SubclassTest->new( { exec => [ $cat => $file ] } ); + my $file = catfile( @t_path, 't', 'data', 'catme.1' ); + my $p = TAP::Parser::SubclassTest->new( + { exec => [ $cat => $file ], + sources => { MySourceHandler => { accept_all => 1 } }, + } + ); - 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' ); + is( $CUSTOM{MySourceHandler}, 1, 'customized a MySourceHandler' ); + is( $INIT{MyIterator}, 1, 'initialized MyIterator subclass' ); } diff --git a/cpan/Test-Harness/t/premature-bailout.t b/cpan/Test-Harness/t/premature-bailout.t index 9226a44064..537e2e498a 100644 --- a/cpan/Test-Harness/t/premature-bailout.t +++ b/cpan/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::IteratorFactory; +use TAP::Parser::Iterator::Array; sub tap_to_lines { my $string = shift; @@ -26,9 +26,8 @@ Bail out! We ran out of foobar. not ok 5 END_TAP -my $factory = TAP::Parser::IteratorFactory->new; -my $parser = TAP::Parser->new( - { stream => $factory->make_iterator( tap_to_lines($tap) ), +my $parser = TAP::Parser->new( + { iterator => TAP::Parser::Iterator::Array->new( tap_to_lines($tap) ), } ); @@ -106,7 +105,8 @@ 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 => $factory->make_iterator( [ split( /\n/, $more_tap ) ] ), + { iterator => + TAP::Parser::Iterator::Array->new( [ split( /\n/, $more_tap ) ] ), } ); diff --git a/cpan/Test-Harness/t/process.t b/cpan/Test-Harness/t/process.t index 5135d67f95..63a8620dfc 100644 --- a/cpan/Test-Harness/t/process.t +++ b/cpan/Test-Harness/t/process.t @@ -28,6 +28,10 @@ my @expect = ( ); my $source = File::Spec->catfile( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test-Harness' ) + : () + ), 't', 'sample-tests', 'delayed' diff --git a/cpan/Test-Harness/t/prove.t b/cpan/Test-Harness/t/prove.t index 71730cdbf6..9a9d36f768 100644 --- a/cpan/Test-Harness/t/prove.t +++ b/cpan/Test-Harness/t/prove.t @@ -1,7 +1,13 @@ #!/usr/bin/perl -w BEGIN { - unshift @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + unshift @INC, 't/lib'; + } } use strict; @@ -10,6 +16,7 @@ use Test::More; use File::Spec; use App::Prove; +use Getopt::Long; package FakeProve; use vars qw( @ISA ); @@ -69,11 +76,13 @@ sub mabs { } } -my ( @ATTR, %DEFAULT_ASSERTION, @SCHEDULE ); +my ( @ATTR, %DEFAULT_ASSERTION, @SCHEDULE, $HAS_YAML ); # see the "ACTUAL TEST" section at the bottom BEGIN { # START PLAN + $HAS_YAML = 0; + eval { require YAML; $HAS_YAML = 1; }; # list of attributes @ATTR = qw( @@ -1008,7 +1017,9 @@ BEGIN { # START PLAN args => { argv => [qw( one two three )], }, - proverc => 't/proverc/emptyexec', + proverc => $ENV{PERL_CORE} + ? '../ext/Test-Harness/t/proverc/emptyexec' + : 't/proverc/emptyexec', switches => [$dummy_test], expect => { exec => '' }, runlog => [ @@ -1080,6 +1091,66 @@ BEGIN { # START PLAN ], }, + # Source handlers + { name => 'Switch --source simple', + args => { argv => [qw( one two three )] }, + switches => [ '--source', 'MyCustom', $dummy_test ], + expect => { + sources => { + MyCustom => {}, + }, + }, + runlog => [ + [ '_runtests', + { sources => { + MyCustom => {}, + }, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --sources with config', + args => { argv => [qw( one two three )] }, + skip => $Getopt::Long::VERSION >= 2.28 && $HAS_YAML ? 0 : 1, + skip_reason => "YAML not available or Getopt::Long too old", + switches => [ + '--source', 'Perl', + '--perl-option', 'foo=bar baz', + '--perl-option', 'avg=0.278', + '--source', 'MyCustom', + '--source', 'File', + '--file-option', 'extensions=.txt', + '--file-option', 'extensions=.tmp', + $dummy_test + ], + expect => { + sources => { + Perl => { foo => 'bar baz', avg => 0.278 }, + MyCustom => {}, + File => { extensions => [ '.txt', '.tmp' ] }, + }, + }, + runlog => [ + [ '_runtests', + { sources => { + Perl => { foo => 'bar baz', avg => 0.278 }, + MyCustom => {}, + File => { extensions => [ '.txt', '.tmp' ] }, + }, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + # Plugins { name => 'Load plugin', switches => [ '-P', 'Dummy', $dummy_test ], @@ -1433,9 +1504,12 @@ BEGIN { # START PLAN my $extra_plan = 0; for my $test (@SCHEDULE) { - $extra_plan += $test->{plan} || 0; - $extra_plan += 2 if $test->{runlog}; - $extra_plan += 1 if $test->{switches}; + my $plan = 0; + $plan += $test->{plan} || 0; + $plan += 2 if $test->{runlog}; + $plan += 1 if $test->{switches}; + $test->{_planned} = $plan + 3 + @ATTR; + $extra_plan += $plan; } plan tests => @SCHEDULE * ( 3 + @ATTR ) + $extra_plan; @@ -1446,80 +1520,89 @@ for my $test (@SCHEDULE) { my $name = $test->{name}; my $class = $test->{class} || 'FakeProve'; - local $ENV{HARNESS_TIMER}; + SKIP: + { + skip $test->{skip_reason}, $test->{_planned} if $test->{skip}; - ok my $app = $class->new( exists $test->{args} ? $test->{args} : () ), - "$name: App::Prove created OK"; + local $ENV{HARNESS_TIMER}; - isa_ok $app, 'App::Prove'; - isa_ok $app, $class; + ok my $app = $class->new( exists $test->{args} ? $test->{args} : () ), + "$name: App::Prove created OK"; - # Optionally parse command args - if ( my $switches = $test->{switches} ) { - if ( my $proverc = $test->{proverc} ) { - $app->add_rc_file( File::Spec->catfile( split /\//, $proverc ) ); - } - eval { $app->process_args( '--norc', @$switches ) }; - if ( my $err_pattern = $test->{parse_error} ) { - like $@, $err_pattern, "$name: expected parse error"; - } - else { - ok !$@, "$name: no parse error"; - } - } - - my $expect = $test->{expect} || {}; - for my $attr ( sort @ATTR ) { - my $val = $app->$attr(); - my $assertion - = exists $expect->{$attr} - ? $expect->{$attr} - : $DEFAULT_ASSERTION{$attr}; - my $is_ok = undef; - - if ( 'CODE' eq ref $assertion ) { - $is_ok = ok $assertion->( $val, $attr ), - "$name: $attr has the expected value"; - } - elsif ( 'Regexp' eq ref $assertion ) { - $is_ok = like $val, $assertion, "$name: $attr matches $assertion"; - } - else { - $is_ok = is_deeply $val, $assertion, - "$name: $attr has the expected value"; - } + isa_ok $app, 'App::Prove'; + isa_ok $app, $class; - unless ($is_ok) { - diag "got $val for $attr"; + # Optionally parse command args + if ( my $switches = $test->{switches} ) { + if ( my $proverc = $test->{proverc} ) { + $app->add_rc_file( + File::Spec->catfile( split /\//, $proverc ) ); + } + eval { $app->process_args( '--norc', @$switches ) }; + if ( my $err_pattern = $test->{parse_error} ) { + like $@, $err_pattern, "$name: expected parse error"; + } + else { + ok !$@, "$name: no parse error"; + } } - } - if ( my $runlog = $test->{runlog} ) { - eval { $app->run }; - if ( my $err_pattern = $test->{run_error} ) { - like $@, $err_pattern, "$name: expected error OK"; - pass; - pass for 1 .. $test->{plan}; - } - else { - unless ( ok !$@, "$name: no error OK" ) { - diag "$name: error: $@\n"; + my $expect = $test->{expect} || {}; + for my $attr ( sort @ATTR ) { + my $val = $app->$attr(); + my $assertion + = exists $expect->{$attr} + ? $expect->{$attr} + : $DEFAULT_ASSERTION{$attr}; + my $is_ok = undef; + + if ( 'CODE' eq ref $assertion ) { + $is_ok = ok $assertion->( $val, $attr ), + "$name: $attr has the expected value"; + } + elsif ( 'Regexp' eq ref $assertion ) { + $is_ok = like $val, $assertion, + "$name: $attr matches $assertion"; + } + else { + $is_ok = is_deeply $val, $assertion, + "$name: $attr has the expected value"; } - my $gotlog = [ $app->get_log ]; - - if ( my $extra = $test->{extra} ) { - $extra->($gotlog); + unless ($is_ok) { + diag "got $val for $attr"; } + } - unless ( - is_deeply $gotlog, $runlog, - "$name: run results match" - ) - { - use Data::Dumper; - diag Dumper( { wanted => $runlog, got => $gotlog } ); + if ( my $runlog = $test->{runlog} ) { + eval { $app->run }; + if ( my $err_pattern = $test->{run_error} ) { + like $@, $err_pattern, "$name: expected error OK"; + pass; + pass for 1 .. $test->{plan}; + } + else { + unless ( ok !$@, "$name: no error OK" ) { + diag "$name: error: $@\n"; + } + + my $gotlog = [ $app->get_log ]; + + if ( my $extra = $test->{extra} ) { + $extra->($gotlog); + } + + unless ( + is_deeply $gotlog, $runlog, + "$name: run results match" + ) + { + use Data::Dumper; + diag Dumper( { wanted => $runlog, got => $gotlog } ); + } } } - } + + } # SKIP } + diff --git a/cpan/Test-Harness/t/proverc.t b/cpan/Test-Harness/t/proverc.t index 37d6de803b..5a7d97e161 100644 --- a/cpan/Test-Harness/t/proverc.t +++ b/cpan/Test-Harness/t/proverc.t @@ -1,5 +1,15 @@ #!/usr/bin/perl -w +BEGIN { + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', 'lib' ); + } + else { + unshift @INC, 't/lib'; + } +} + use strict; use lib 't/lib'; use Test::More tests => 1; @@ -10,6 +20,10 @@ my $prove = App::Prove->new; $prove->add_rc_file( File::Spec->catfile( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test-Harness' ) + : () + ), 't', 'data', 'proverc' ) diff --git a/cpan/Test-Harness/t/proverun.t b/cpan/Test-Harness/t/proverun.t index 6e6c2f33f5..50396279db 100644 --- a/cpan/Test-Harness/t/proverun.t +++ b/cpan/Test-Harness/t/proverun.t @@ -1,7 +1,13 @@ #!/usr/bin/perl -w BEGIN { - unshift @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', 'lib' ); + } + else { + unshift @INC, 't/lib'; + } } use strict; @@ -12,6 +18,13 @@ use App::Prove; my @SCHEDULE; BEGIN { + my $t_dir = File::Spec->catdir( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test-Harness' ) + : () + ), + 't' + ); # to add a new test to proverun, just list the name of the file in # t/sample-tests and a name for the test. The rest is handled @@ -24,14 +37,15 @@ BEGIN { name => 'Passing TODO', }, ); - foreach my $test (@tests) { + + # TODO: refactor this and add in a test for: + # prove --source 'File: {extensions: [.1]}' t/source_tests/source.1 + + for my $test (@tests) { # let's fully expand that filename - $test->{file} = File::Spec->catfile( - 't', - 'sample-tests', - $test->{file} - ); + $test->{file} + = File::Spec->catfile( $t_dir, 'sample-tests', $test->{file} ); } @SCHEDULE = ( map { @@ -52,7 +66,7 @@ BEGIN { ] ] } - } @tests + } @tests, ); plan tests => @SCHEDULE * 3; diff --git a/cpan/Test-Harness/t/regression.t b/cpan/Test-Harness/t/regression.t index 20879ca2b6..b86dd07233 100644 --- a/cpan/Test-Harness/t/regression.t +++ b/cpan/Test-Harness/t/regression.t @@ -1,7 +1,13 @@ #!/usr/bin/perl -w BEGIN { - push @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } + else { + push @INC, 't/lib'; + } } use strict; @@ -24,6 +30,10 @@ my $IsWin32 = $^O eq 'MSWin32'; my $SAMPLE_TESTS = File::Spec->catdir( File::Spec->curdir, + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test-Harness' ) + : () + ), 't', 'sample-tests' ); diff --git a/cpan/Test-Harness/t/sample-tests/delayed b/cpan/Test-Harness/t/sample-tests/delayed index 1f24ef6790..f016a69348 100644 --- a/cpan/Test-Harness/t/sample-tests/delayed +++ b/cpan/Test-Harness/t/sample-tests/delayed @@ -1,4 +1,10 @@ # Used to test Process.pm +BEGIN { + if ( $ENV{PERL_CORE} ) { + @INC = '../lib'; + } +} + use Time::HiRes qw(sleep); my $delay = 0.01; diff --git a/cpan/Test-Harness/t/source.t b/cpan/Test-Harness/t/source.t index ce9063e57b..80b74f5bc8 100644..100755 --- a/cpan/Test-Harness/t/source.t +++ b/cpan/Test-Harness/t/source.t @@ -1,93 +1,301 @@ #!/usr/bin/perl -w BEGIN { - unshift @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + unshift @INC, 't/lib'; + } } use strict; -use Test::More tests => 26; - +use Test::More tests => 45; use File::Spec; -use EmptyParser; -use TAP::Parser::Source; -use TAP::Parser::Source::Perl; - -my $parser = EmptyParser->new; -my $test = File::Spec->catfile( +my $dir = File::Spec->catdir( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test-Harness' ) + : () + ), 't', - 'source_tests', - 'source' + 'source_tests' ); -my $perl = $^X; - -can_ok 'TAP::Parser::Source', 'new'; -my $source = TAP::Parser::Source->new; -isa_ok $source, 'TAP::Parser::Source'; - -can_ok $source, 'source'; -eval { $source->source("$perl -It/lib $test") }; -ok my $error = $@, '... and calling it with a string should fail'; -like $error, qr/^Argument to &source must be an array reference/, - '... with an appropriate error message'; -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($parser); - -isa_ok $stream, 'TAP::Parser::Iterator::Process', - 'get_stream returns the right object'; -can_ok $stream, 'next'; -is $stream->next, '1..1', '... and the first line should be correct'; -is $stream->next, 'ok 1', '... as should the second'; -ok !$stream->next, '... and we should have no more results'; - -can_ok 'TAP::Parser::Source::Perl', 'new'; -$source = TAP::Parser::Source::Perl->new; -isa_ok $source, 'TAP::Parser::Source::Perl', '... and the object it returns'; - -can_ok $source, 'source'; -ok $source->source( [$test] ), - '... and calling it with valid args should succeed'; - -can_ok $source, 'get_stream'; -$stream = $source->get_stream($parser); - -isa_ok $stream, 'TAP::Parser::Iterator::Process', - '... and the object it returns'; -can_ok $stream, 'next'; -is $stream->next, '1..1', '... and the first line should be correct'; -is $stream->next, 'ok 1', '... as should the second'; -ok !$stream->next, '... and we should have no more results'; - -# internals tests! - -can_ok $source, '_switches'; -ok( grep( $_ =~ /^['"]?-T['"]?$/, $source->_switches ), - '... and it should find the taint switch' -); +use_ok('TAP::Parser::Source'); + +# Basic tests +{ + my $source = TAP::Parser::Source->new; + isa_ok( $source, 'TAP::Parser::Source', 'new source' ); + can_ok( + $source, + qw( raw meta config merge switches test_args assemble_meta ) + ); + + is_deeply( $source->config, {}, 'config empty by default' ); + $source->config->{Foo} = { bar => 'baz' }; + is_deeply( + $source->config_for('Foo'), { bar => 'baz' }, + 'config_for( Foo )' + ); + is_deeply( + $source->config_for('TAP::Parser::SourceHandler::Foo'), + { bar => 'baz' }, 'config_for( ...::SourceHandler::Foo )' + ); + + ok( !$source->merge, 'merge not set by default' ); + $source->merge(1); + ok( $source->merge, '... merge now set' ); + + is( $source->switches, undef, 'switches not set by default' ); + $source->switches( ['-Ilib'] ); + is_deeply( $source->switches, ['-Ilib'], '... switches now set' ); + + is( $source->test_args, undef, 'test_args not set by default' ); + $source->test_args( ['foo'] ); + is_deeply( $source->test_args, ['foo'], '... test_args now set' ); -# coverage test for TAP::PArser::Source + $source->raw( \'hello world' ); + my $meta = $source->assemble_meta; + is_deeply( + $meta, + { is_scalar => 1, + is_object => 0, + has_newlines => 0, + length => 11, + }, + 'assemble_meta for scalar that isnt a file' + ); + + is( $source->meta, $meta, '... and caches meta' ); +} + +# array check +{ + my $source = TAP::Parser::Source->new; + $source->raw( [ 'hello', 'world' ] ); + my $meta = $source->assemble_meta; + is_deeply( + $meta, + { is_array => 1, + is_object => 0, + size => 2, + }, + 'assemble_meta for array' + ); +} + +# hash check +{ + my $source = TAP::Parser::Source->new; + $source->raw( { hello => 'world' } ); + my $meta = $source->assemble_meta; + is_deeply( + $meta, + { is_hash => 1, + is_object => 0, + }, + 'assemble_meta for array' + ); +} +# glob check { + my $source = TAP::Parser::Source->new; + $source->raw( \*__DATA__ ); + my $meta = $source->assemble_meta; + is_deeply( + $meta, + { is_glob => 1, + is_object => 0, + }, + 'assemble_meta for array' + ); +} + +# object check +{ + my $source = TAP::Parser::Source->new; + $source->raw( bless {}, 'Foo::Bar' ); + my $meta = $source->assemble_meta; + is_deeply( + $meta, + { is_object => 1, + class => 'Foo::Bar', + }, + 'assemble_meta for array' + ); +} + +# file test +{ + my $test = File::Spec->catfile( $dir, 'source.t' ); + my $source = TAP::Parser::Source->new; + + $source->raw( \$test ); + my $meta = $source->assemble_meta; + + # separate meta->file to break up the test + my $file = delete $meta->{file}; + is_deeply( + $meta, + { is_scalar => 1, + has_newlines => 0, + length => length($test), + is_object => 0, + is_file => 1, + is_dir => 0, + is_symlink => 0, + }, + 'assemble_meta for file' + ); + + # now check file meta - remove things that will vary between platforms + my $stat = delete $file->{stat}; + is( @$stat, 13, '... file->stat set' ); + ok( delete $file->{size}, '... file->size set' ); + ok( delete $file->{dir}, '... file->dir set' ); + isnt( delete $file->{read}, undef, '... file->read set' ); + isnt( delete $file->{write}, undef, '... file->write set' ); + isnt( delete $file->{execute}, undef, '... file->execute set' ); + is_deeply( + $file, + { basename => 'source.t', + ext => '.t', + lc_ext => '.t', + shebang => '#!/usr/bin/perl', + binary => 0, + text => 1, + empty => 0, + exists => 1, + is_dir => 0, + is_file => 1, + is_symlink => 0, + sticky => 0, + setgid => 0, + setuid => 0, + }, + '... file->* set' + ); +} + +# dir test +{ + my $test = File::Spec->catfile($dir); + my $source = TAP::Parser::Source->new; + + $source->raw( \$test ); + my $meta = $source->assemble_meta; + + # separate meta->file to break up the test + my $file = delete $meta->{file}; + is_deeply( + $meta, + { is_scalar => 1, + has_newlines => 0, + length => length($test), + is_object => 0, + is_file => 0, + is_dir => 1, + is_symlink => 0, + }, + 'assemble_meta for directory' + ); + + # now check file meta - remove things that will vary between platforms + my $stat = delete $file->{stat}; + is( @$stat, 13, '... file->stat set' ); + ok( delete $file->{dir}, '... file->dir set' ); + isnt( delete $file->{size}, undef, '... file->size set' ); + isnt( delete $file->{binary}, undef, '... file->binary set' ); + isnt( delete $file->{empty}, undef, '... file->empty set' ); + isnt( delete $file->{read}, undef, '... file->read set' ); + isnt( delete $file->{write}, undef, '... file->write set' ); + isnt( delete $file->{execute}, undef, '... file->execute set' ); + is_deeply( + $file, + { basename => 'source_tests', + ext => '', + lc_ext => '', + text => 0, + exists => 1, + is_dir => 1, + is_file => 0, + is_symlink => 0, + sticky => 0, + setgid => 0, + setuid => 0, + }, + '... file->* set' + ); +} - # coverage for method get_steam +# symlink test +SKIP: { + my $symlink_exists = eval { symlink( '', '' ); 1 }; + skip 'symlink not supported on this platform', 9 unless $symlink_exists; - my $source = TAP::Parser::Source->new( { parser => $parser } ); + my $test = File::Spec->catfile( $dir, 'source.t' ); + my $symlink = File::Spec->catfile( $dir, 'source_link.T' ); + my $source = TAP::Parser::Source->new; - my @die; + eval { symlink( File::Spec->rel2abs($test), $symlink ) }; + if ( my $e = $@ ) { + diag($@); + die "aborting test"; + } - eval { - local $SIG{__DIE__} = sub { push @die, @_ }; + $source->raw( \$symlink ); + my $meta = $source->assemble_meta; - $source->get_stream; - }; + # separate meta->file to break up the test + my $file = delete $meta->{file}; + is_deeply( + $meta, + { is_scalar => 1, + has_newlines => 0, + length => length($symlink), + is_object => 0, + is_file => 1, + is_dir => 0, + is_symlink => 1, + }, + 'assemble_meta for symlink' + ); - is @die, 1, 'coverage testing of get_stream'; + # now check file meta - remove things that will vary between platforms + my $stat = delete $file->{stat}; + is( @$stat, 13, '... file->stat set' ); + my $lstat = delete $file->{lstat}; + is( @$lstat, 13, '... file->lstat set' ); + ok( delete $file->{size}, '... file->size set' ); + ok( delete $file->{dir}, '... file->dir set' ); + isnt( delete $file->{read}, undef, '... file->read set' ); + isnt( delete $file->{write}, undef, '... file->write set' ); + isnt( delete $file->{execute}, undef, '... file->execute set' ); + is_deeply( + $file, + { basename => 'source_link.T', + ext => '.T', + lc_ext => '.t', + shebang => '#!/usr/bin/perl', + binary => 0, + text => 1, + empty => 0, + exists => 1, + is_dir => 0, + is_file => 1, + is_symlink => 1, + sticky => 0, + setgid => 0, + setuid => 0, + }, + '... file->* set' + ); - like pop @die, qr/No command found!/, '...and it failed as expect'; + unlink $symlink; } diff --git a/cpan/Test-Harness/t/source_handler.t b/cpan/Test-Harness/t/source_handler.t new file mode 100644 index 0000000000..d06a26fb82 --- /dev/null +++ b/cpan/Test-Harness/t/source_handler.t @@ -0,0 +1,492 @@ +#!/usr/bin/perl -w + +BEGIN { + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +use Test::More tests => 123; + +use IO::File; +use IO::Handle; +use File::Spec; +use MyShebangger; + +use TAP::Parser::Source; +use TAP::Parser::SourceHandler; + +my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ ); +my $HAS_SH = -x '/bin/sh'; +my $HAS_ECHO = -x '/bin/echo'; + +my $dir = File::Spec->catdir( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test-Harness' ) + : () + ), + 't', + 'source_tests' +); + +my $perl = $^X; + +my %file = map { $_ => File::Spec->catfile( $dir, $_ ) } + qw( source source.1 source.bat source.pl source.sh source.t source.tap ); + +# Abstract base class tests +{ + my $class = 'TAP::Parser::SourceHandler'; + my $source = TAP::Parser::Source->new; + my $error; + + can_ok $class, 'can_handle'; + eval { $class->can_handle($source) }; + $error = $@; + like $error, qr/^Abstract method 'can_handle'/, + '... with an appropriate error message'; + + can_ok $class, 'make_iterator'; + eval { $class->make_iterator($source) }; + $error = $@; + like $error, qr/^Abstract method 'make_iterator'/, + '... with an appropriate error message'; +} + +# Executable source tests +{ + my $class = 'TAP::Parser::SourceHandler::Executable'; + my $tests = { + default_vote => 0, + can_handle => [ + { name => '.sh', + meta => { + is_file => 1, + file => { lc_ext => '.sh' } + }, + vote => 0.8, + }, + { name => '.bat', + meta => { + is_file => 1, + file => { lc_ext => '.bat' } + }, + vote => 0.8, + }, + { name => 'executable bit', + meta => { + is_file => 1, + file => { lc_ext => '', execute => 1 } + }, + vote => 0.7, + }, + { name => 'exec hash', + raw => { exec => 'foo' }, + meta => { is_hash => 1 }, + vote => 0.9, + }, + ], + make_iterator => [ + { name => "valid executable", + raw => [ $perl, '-It/lib', '-T', $file{source} ], + iclass => 'TAP::Parser::Iterator::Process', + output => [ '1..1', 'ok 1 - source' ], + assemble_meta => 1, + }, + { name => "invalid source->raw", + raw => "$perl -It/lib $file{source}", + error => qr/^No command found/, + }, + { name => "non-existent source->raw", + raw => [], + error => qr/^No command found/, + }, + { name => $file{'source.sh'}, + raw => \$file{'source.sh'}, + skip => $HAS_SH && $HAS_ECHO ? 0 : 1, + skip_reason => 'no /bin/sh, /bin/echo', + iclass => 'TAP::Parser::Iterator::Process', + output => [ '1..1', 'ok 1 - source.sh' ], + assemble_meta => 1, + }, + { name => $file{'source.bat'}, + raw => \$file{'source.bat'}, + skip => $IS_WIN32 ? 0 : 1, + skip_reason => 'not running Win32', + iclass => 'TAP::Parser::Iterator::Process', + output => [ '1..1', 'ok 1 - source.bat' ], + assemble_meta => 1, + }, + ], + }; + + test_handler( $class, $tests ); +} + +# Perl source tests +{ + my $class = 'TAP::Parser::SourceHandler::Perl'; + my $tests = { + default_vote => 0, + can_handle => [ + { name => '.t', + meta => { + is_file => 1, + file => { lc_ext => '.t', dir => '' } + }, + vote => 0.8, + }, + { name => '.pl', + meta => { + is_file => 1, + file => { lc_ext => '.pl', dir => '' } + }, + vote => 0.9, + }, + { name => 't/.../file', + meta => { + is_file => 1, + file => { lc_ext => '', dir => 't' } + }, + vote => 0.75, + }, + { name => '#!...perl', + meta => { + is_file => 1, + file => { + lc_ext => '', dir => '', shebang => '#!/usr/bin/perl' + } + }, + vote => 0.9, + }, + { name => 'file default', + meta => { + is_file => 1, + file => { lc_ext => '', dir => '' } + }, + vote => 0.25, + }, + ], + make_iterator => [ + { name => $file{source}, + raw => \$file{source}, + iclass => 'TAP::Parser::Iterator::Process', + output => [ '1..1', 'ok 1 - source' ], + assemble_meta => 1, + }, + ], + }; + + test_handler( $class, $tests ); + + # internals tests! + { + my $source = TAP::Parser::Source->new->raw( \$file{source} ); + $source->assemble_meta; + my $iterator = $class->make_iterator($source); + my @command = @{ $iterator->{command} }; + ok( grep( $_ =~ /^['"]?-T['"]?$/, @command ), + '... and it should find the taint switch' + ); + } +} + +# Raw TAP source tests +{ + my $class = 'TAP::Parser::SourceHandler::RawTAP'; + my $tests = { + default_vote => 0, + can_handle => [ + { name => 'file', + meta => { is_file => 1 }, + raw => \'', + vote => 0, + }, + { name => 'scalar w/newlines', + raw => \"hello\nworld\n", + vote => 0.3, + assemble_meta => 1, + }, + { name => '1..10', + raw => \"1..10\n", + vote => 0.9, + assemble_meta => 1, + }, + { name => 'array', + raw => [ '1..1', 'ok 1' ], + vote => 0.5, + assemble_meta => 1, + }, + ], + make_iterator => [ + { name => 'valid scalar', + raw => \"1..1\nok 1 - raw\n", + iclass => 'TAP::Parser::Iterator::Array', + output => [ '1..1', 'ok 1 - raw' ], + assemble_meta => 1, + }, + { name => 'valid array', + raw => [ '1..1', 'ok 1 - raw' ], + iclass => 'TAP::Parser::Iterator::Array', + output => [ '1..1', 'ok 1 - raw' ], + assemble_meta => 1, + }, + ], + }; + + test_handler( $class, $tests ); +} + +# Text file TAP source tests +{ + my $class = 'TAP::Parser::SourceHandler::File'; + my $tests = { + default_vote => 0, + can_handle => [ + { name => '.tap', + meta => { + is_file => 1, + file => { lc_ext => '.tap' } + }, + vote => 0.9, + }, + { name => '.foo with config', + meta => { + is_file => 1, + file => { lc_ext => '.foo' } + }, + config => { File => { extensions => ['.foo'] } }, + vote => 0.9, + }, + ], + make_iterator => [ + { name => $file{'source.tap'}, + raw => \$file{'source.tap'}, + iclass => 'TAP::Parser::Iterator::Stream', + output => [ '1..1', 'ok 1 - source.tap' ], + assemble_meta => 1, + }, + { name => $file{'source.1'}, + raw => \$file{'source.1'}, + config => { File => { extensions => ['.1'] } }, + iclass => 'TAP::Parser::Iterator::Stream', + output => [ '1..1', 'ok 1 - source.1' ], + assemble_meta => 1, + }, + ], + }; + + test_handler( $class, $tests ); +} + +# IO::Handle TAP source tests +{ + my $class = 'TAP::Parser::SourceHandler::Handle'; + my $tests = { + default_vote => 0, + can_handle => [ + { name => 'glob', + meta => { is_glob => 1 }, + vote => 0.8, + }, + { name => 'IO::Handle', + raw => IO::Handle->new, + vote => 0.9, + assemble_meta => 1, + }, + ], + make_iterator => [ + { name => 'IO::Handle', + raw => IO::File->new( $file{'source.tap'} ), + iclass => 'TAP::Parser::Iterator::Stream', + output => [ '1..1', 'ok 1 - source.tap' ], + assemble_meta => 1, + }, + ], + }; + + test_handler( $class, $tests ); +} + +# pgTAP source tests +{ + my $class = 'TAP::Parser::SourceHandler::pgTAP'; + my $test = File::Spec->catfile( $dir, 'source.t' ); + my $psql = File::Spec->catfile( $dir, 'psql' ); + if ( $^O eq 'MSWin32' ) { + $psql .= '.bat'; + } + else { + $psql = MyShebangger::make_perl_executable($psql); + } + my @command = qw( + --no-psqlrc + --no-align + --quiet + --pset pager= + --pset tuples_only=true + --set ON_ERROR_ROLLBACK=1 + --set ON_ERROR_STOP=1 + ); + my $tests = { + default_vote => 0, + can_handle => [ + { name => '.pg', + meta => { + is_file => 1, + file => { lc_ext => '.pg' } + }, + config => {}, + vote => 0.9, + }, + { name => '.sql', + meta => { + is_file => 1, + file => { lc_ext => '.sql' } + }, + config => {}, + vote => 0.8, + }, + { name => '.s', + meta => { + is_file => 1, + file => { lc_ext => '.s' } + }, + config => {}, + vote => 0.75, + }, + { name => 'config_suffix', + meta => { + is_file => 1, + file => { lc_ext => '.foo' } + }, + config => { pgTAP => { suffix => '.foo' } }, + vote => 1, + }, + { name => 'not_file', + meta => { + is_file => 0, + }, + vote => 0, + }, + ], + make_iterator => [ + { name => 'psql', + raw => \$test, + config => { pgTAP => { psql => $psql } }, + iclass => 'TAP::Parser::Iterator::Process', + output => [ @command, '--file', $test ], + }, + { name => 'config', + raw => $test, + config => { + pgTAP => { + psql => $psql, + username => 'who', + host => 'f', + port => 2, + dbname => 'fred', + } + }, + iclass => 'TAP::Parser::Iterator::Process', + output => [ + @command, + qw(--username who --host f --port 2 --dbname fred --file), + $test + ], + }, + { name => 'error', + raw => 'blah.pg', + iclass => 'TAP::Parser::Iterator::Process', + error => qr/^No such file or directory: blah[.]pg/, + }, + { name => 'undef error', + raw => undef, + iclass => 'TAP::Parser::Iterator::Process', + error => qr/^No such file or directory: /, + }, + ], + }; + + test_handler( $class, $tests ); +} + +exit; + +############################################################################### +# helper sub + +sub test_handler { + my ( $class, $tests ) = @_; + my ($short_class) = ( $class =~ /\:\:(\w+)$/ ); + + use_ok $class; + can_ok $class, 'can_handle', 'make_iterator'; + + { + my $default_vote = $tests->{default_vote} || 0; + my $source = TAP::Parser::Source->new; + is( $class->can_handle($source), $default_vote, + '... can_handle default vote' + ); + } + + for my $test ( @{ $tests->{can_handle} } ) { + my $source = TAP::Parser::Source->new; + $source->raw( $test->{raw} ) if $test->{raw}; + $source->meta( $test->{meta} ) if $test->{meta}; + $source->config( $test->{config} ) if $test->{config}; + $source->assemble_meta if $test->{assemble_meta}; + my $vote = $test->{vote} || 0; + my $name = $test->{name} || 'unnamed test'; + $name = "$short_class->can_handle( $name )"; + is( $class->can_handle($source), $vote, $name ); + } + + for my $test ( @{ $tests->{make_iterator} } ) { + my $name = $test->{name} || 'unnamed test'; + $name = "$short_class->make_iterator( $name )"; + + SKIP: + { + my $planned = 1; + $planned += 1 + scalar @{ $test->{output} } if $test->{output}; + skip $test->{skip_reason}, $planned if $test->{skip}; + + my $source = TAP::Parser::Source->new; + $source->raw( $test->{raw} ) if $test->{raw}; + $source->meta( $test->{meta} ) if $test->{meta}; + $source->config( $test->{config} ) if $test->{config}; + $source->assemble_meta if $test->{assemble_meta}; + + my $iterator = eval { $class->make_iterator($source) }; + my $e = $@; + if ( my $error = $test->{error} ) { + $e = '' unless defined $e; + like $e, $error, "$name threw expected error"; + next; + } + elsif ($e) { + fail("$name threw an unexpected error"); + diag($e); + next; + } + + isa_ok $iterator, $test->{iclass}, $name; + if ( $test->{output} ) { + my $i = 1; + for my $line ( @{ $test->{output} } ) { + is $iterator->next, $line, "... line $i"; + $i++; + } + ok !$iterator->next, '... and we should have no more results'; + } + } + } +} diff --git a/cpan/Test-Harness/t/source_tests/psql b/cpan/Test-Harness/t/source_tests/psql new file mode 100755 index 0000000000..f32e6a7ff6 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/psql @@ -0,0 +1,3 @@ +#!/usr/bin/perl + +print $_, $/ for @ARGV; diff --git a/cpan/Test-Harness/t/source_tests/psql.bat b/cpan/Test-Harness/t/source_tests/psql.bat new file mode 100755 index 0000000000..29daf614c8 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/psql.bat @@ -0,0 +1,19 @@ +@rem = '--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +perl -x -S %0 %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem '; +#!/usr/bin/perl +#line 15 + +print $_, $/ for @ARGV; + +__END__ +:endofperl diff --git a/cpan/Test-Harness/t/source_tests/source b/cpan/Test-Harness/t/source_tests/source index be28995e63..a7dc38e34f 100644 --- a/cpan/Test-Harness/t/source_tests/source +++ b/cpan/Test-Harness/t/source_tests/source @@ -2,7 +2,8 @@ BEGIN { if ( $ENV{PERL_CORE} ) { - @INC = ( '../../lib', 't/lib' ); + chdir 't'; + @INC = ( '../lib', 'lib' ); } else { unshift @INC, 't/lib'; @@ -11,4 +12,4 @@ BEGIN { use Test::More tests => 1; -ok 1; +ok 1, 'source'; diff --git a/cpan/Test-Harness/t/source_tests/source.1 b/cpan/Test-Harness/t/source_tests/source.1 new file mode 100644 index 0000000000..879d2d2c3b --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/source.1 @@ -0,0 +1,2 @@ +1..1 +ok 1 - source.1 diff --git a/cpan/Test-Harness/t/source_tests/source.bat b/cpan/Test-Harness/t/source_tests/source.bat new file mode 100644 index 0000000000..a9fad1e399 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/source.bat @@ -0,0 +1,4 @@ +@ECHO OFF +REM this comment will fail if you try to run it through sh! +ECHO 1..1 +ECHO ok 1 - source.bat diff --git a/cpan/Test-Harness/t/source_tests/source.pl b/cpan/Test-Harness/t/source_tests/source.pl new file mode 100644 index 0000000000..e709bac989 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/source.pl @@ -0,0 +1,6 @@ +#!/usr/bin/perl + +print <<'END_TESTS'; +1..1 +ok 1 - source.pl +END_TESTS diff --git a/cpan/Test-Harness/t/source_tests/source.sh b/cpan/Test-Harness/t/source_tests/source.sh new file mode 100755 index 0000000000..112f56df22 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/source.sh @@ -0,0 +1,3 @@ +#!/bin/sh +echo "1..1" +echo "ok 1 - source.sh" diff --git a/cpan/Test-Harness/t/source_tests/source.t b/cpan/Test-Harness/t/source_tests/source.t new file mode 100644 index 0000000000..852088782d --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/source.t @@ -0,0 +1,6 @@ +#!/usr/bin/perl + +print <<'END_TESTS'; +1..1 +ok 1 - source.t +END_TESTS diff --git a/cpan/Test-Harness/t/source_tests/source.tap b/cpan/Test-Harness/t/source_tests/source.tap new file mode 100644 index 0000000000..788e656ce0 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/source.tap @@ -0,0 +1,2 @@ +1..1 +ok 1 - source.tap diff --git a/cpan/Test-Harness/t/spool.t b/cpan/Test-Harness/t/spool.t index d22ffcdd77..62227da4fd 100644 --- a/cpan/Test-Harness/t/spool.t +++ b/cpan/Test-Harness/t/spool.t @@ -1,7 +1,13 @@ #!/usr/bin/perl -w BEGIN { - unshift @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', 'lib' ); + } + else { + unshift @INC, 't/lib'; + } } # test T::H::_open_spool and _close_spool - these are good examples @@ -53,6 +59,7 @@ BEGIN { use TAP::Harness; use TAP::Parser; +use TAP::Parser::Iterator::Array; plan tests => 4; @@ -60,7 +67,7 @@ plan tests => 4; # coverage tests for the basically untested T::H::_open_spool - my @spool = ( 't', 'spool' ); + my @spool = ( $ENV{PERL_CORE} ? ('spool') : ( 't', 'spool' ) ); $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool); # now given that we're going to be writing stuff to the file system, make sure we have @@ -112,8 +119,8 @@ END_TAP my $parser = TAP::Parser->new( { spool => $spoolHandle, - stream => - TAP::Parser::IteratorFactory->new( [ split /\n/ => $tap ] ) + iterator => + TAP::Parser::Iterator::Array->new( [ split /\n/ => $tap ] ) } ); diff --git a/cpan/Test-Harness/t/state.t b/cpan/Test-Harness/t/state.t index 2d94e9bbce..a2a58e729c 100644 --- a/cpan/Test-Harness/t/state.t +++ b/cpan/Test-Harness/t/state.t @@ -1,7 +1,13 @@ #!/usr/bin/perl -w BEGIN { - unshift @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } + else { + unshift @INC, 't/lib'; + } } use strict; @@ -9,6 +15,11 @@ use Test::More; use App::Prove::State; use App::Prove::State::Result; +sub mn { + my $pfx = $ENV{PERL_CORE} ? '../ext/Test-Harness/' : ''; + return map {"$pfx$_"} @_; +} + my @schedule = ( { options => 'all', get_tests_args => [], @@ -17,7 +28,7 @@ my @schedule = ( 't/compat/failure.t', 't/compat/inc_taint.t', 't/compat/version.t', - 't/source.t', + 't/source_handler.t', 't/yamlish-writer.t', ], }, @@ -33,7 +44,7 @@ my @schedule = ( expect => [ 't/compat/env.t', 't/compat/failure.t', - 't/source.t', + 't/source_handler.t', 't/yamlish-writer.t', ], }, @@ -44,7 +55,7 @@ my @schedule = ( 't/compat/failure.t', 't/compat/inc_taint.t', 't/compat/version.t', - 't/source.t', + 't/source_handler.t', ], }, { options => 'todo', @@ -71,7 +82,7 @@ my @schedule = ( 't/compat/env.t', 't/compat/failure.t', 't/compat/inc_taint.t', - 't/source.t', + 't/source_handler.t', ], }, { options => 'failed,passed', @@ -81,7 +92,7 @@ my @schedule = ( 't/compat/version.t', 't/compat/env.t', 't/compat/failure.t', - 't/source.t', + 't/source_handler.t', 't/yamlish-writer.t', ], }, @@ -92,7 +103,7 @@ my @schedule = ( 't/compat/version.t', 't/compat/env.t', 't/compat/failure.t', - 't/source.t', + 't/source_handler.t', 't/yamlish-writer.t', ], }, @@ -104,13 +115,13 @@ my @schedule = ( 't/compat/inc_taint.t', 't/compat/version.t', 't/compat/failure.t', - 't/source.t', + 't/source_handler.t', ], }, { options => 'fast', get_tests_args => [], expect => [ - 't/source.t', + 't/source_handler.t', 't/compat/failure.t', 't/compat/version.t', 't/compat/inc_taint.t', @@ -121,7 +132,7 @@ my @schedule = ( { options => 'old', get_tests_args => [], expect => [ - 't/source.t', + 't/source_handler.t', 't/compat/inc_taint.t', 't/compat/version.t', 't/yamlish-writer.t', @@ -137,7 +148,7 @@ my @schedule = ( 't/yamlish-writer.t', 't/compat/version.t', 't/compat/inc_taint.t', - 't/source.t', + 't/source_handler.t', ], }, { options => 'fresh', @@ -164,7 +175,7 @@ for my $test (@schedule) { $state->apply_switch(@$options); my @got = $state->get_tests( @{ $test->{get_tests_args} } ); - my @expect = @{ $test->{expect} }; + my @expect = mn( @{ $test->{expect} } ); unless ( is_deeply \@got, \@expect, "$desc: order OK" ) { use Data::Dumper; diag( Dumper( { got => \@got, want => \@expect } ) ); @@ -176,7 +187,7 @@ sub get_state { { generation => 51, last_run_time => 1196285439, tests => { - 't/compat/failure.t' => { + mn('t/compat/failure.t') => { last_result => 0, last_run_time => 1196371471.57738, last_pass_time => 1196371471.57738, @@ -187,7 +198,7 @@ sub get_state { last_todo => 1, mtime => 1196285623, }, - 't/yamlish-writer.t' => { + mn('t/yamlish-writer.t') => { last_result => 0, last_run_time => 1196371480.5761, last_pass_time => 1196371480.5761, @@ -199,7 +210,7 @@ sub get_state { last_todo => 0, mtime => 1196285400, }, - 't/compat/env.t' => { + mn('t/compat/env.t') => { last_result => 0, last_run_time => 1196371471.42967, last_pass_time => 1196371471.42967, @@ -211,7 +222,7 @@ sub get_state { last_todo => 0, mtime => 1196285739, }, - 't/compat/version.t' => { + mn('t/compat/version.t') => { last_result => 2, last_run_time => 1196371472.96476, last_pass_time => 1196371472.96476, @@ -223,7 +234,7 @@ sub get_state { last_todo => 4, mtime => 1196285239, }, - 't/compat/inc_taint.t' => { + mn('t/compat/inc_taint.t') => { last_result => 3, last_run_time => 1196371471.89682, last_pass_time => 1196371471.89682, @@ -234,7 +245,7 @@ sub get_state { last_todo => 0, mtime => 1196185639, }, - 't/source.t' => { + mn('t/source_handler.t') => { last_result => 0, last_run_time => 1196371479.72508, last_pass_time => 1196371479.72508, diff --git a/cpan/Test-Harness/t/state_results.t b/cpan/Test-Harness/t/state_results.t index fe0b944333..db532c91c1 100644 --- a/cpan/Test-Harness/t/state_results.t +++ b/cpan/Test-Harness/t/state_results.t @@ -1,7 +1,13 @@ #!/usr/bin/perl -w BEGIN { - unshift @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } + else { + unshift @INC, 't/lib'; + } } use strict; diff --git a/cpan/Test-Harness/t/streams.t b/cpan/Test-Harness/t/streams.t index b312ae8367..f4e97671e8 100644..100755 --- a/cpan/Test-Harness/t/streams.t +++ b/cpan/Test-Harness/t/streams.t @@ -3,26 +3,28 @@ use strict; use lib 't/lib'; -use Test::More tests => 47; +use Test::More tests => 49; use TAP::Parser; -use TAP::Parser::IteratorFactory; +use TAP::Parser::Iterator::Array; +use TAP::Parser::Iterator::Stream; -my $STREAMED = 'TAP::Parser'; my $ITER = 'TAP::Parser::Iterator'; my $ITER_FH = "${ITER}::Stream"; my $ITER_ARRAY = "${ITER}::Array"; -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 } ); +my $iterator = $ITER_FH->new( \*DATA ); +isa_ok $iterator, 'TAP::Parser::Iterator'; +my $parser = TAP::Parser->new( { iterator => $iterator } ); isa_ok $parser, 'TAP::Parser', '... and creating a streamed parser should succeed'; -can_ok $parser, '_stream'; -is ref $parser->_stream, $ITER_FH, +can_ok $parser, '_iterator'; +is ref $parser->_iterator, $ITER_FH, '... and it should return the proper iterator'; +can_ok $parser, '_stream'; # deprecated +is $parser->_stream, $parser->_iterator, '... _stream (deprecated)'; + can_ok $parser, 'next'; is $parser->next->as_string, '1..5', '... and the plan should parse correctly'; @@ -57,10 +59,10 @@ ok 5 # skip we have no description 1..5 END_TAP -$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); -ok $parser = TAP::Parser->new( { stream => $stream } ), +$iterator = $ITER_ARRAY->new( [ split /\n/ => $tap ] ); +ok $parser = TAP::Parser->new( { iterator => $iterator } ), 'Now we create a parser with the plan at the end'; -isa_ok $parser->_stream, $ITER_ARRAY, +isa_ok $parser->_iterator, $ITER_ARRAY, '... and now we should have an array iterator'; is $parser->next->as_string, 'ok 1 - input file opened', '... and the first test should parse correctly'; @@ -95,9 +97,9 @@ not ok 4 - this is a real failure ok 5 # skip we have no description END_TAP -$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); +$iterator = $ITER_ARRAY->new( [ split /\n/ => $tap ] ); -ok $parser = TAP::Parser->new( { stream => $stream } ), +ok $parser = TAP::Parser->new( { iterator => $iterator } ), 'Now we create a parser with a plan as the second line'; is $parser->next->as_string, 'ok 1 - input file opened', '... and the first test should parse correctly'; @@ -133,9 +135,9 @@ not ok 4 - this is a real failure ok 5 # skip we have no description END_TAP -$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); +$iterator = $ITER_ARRAY->new( [ split /\n/ => $tap ] ); -ok $parser = TAP::Parser->new( { stream => $stream } ), +ok $parser = TAP::Parser->new( { iterator => $iterator } ), 'Now we create a parser with the plan as the second to last line'; is $parser->next->as_string, 'ok 1 - input file opened', '... and the first test should parse correctly'; diff --git a/cpan/Test-Harness/t/taint.t b/cpan/Test-Harness/t/taint.t index 2812fc4375..80acec8fb1 100644 --- a/cpan/Test-Harness/t/taint.t +++ b/cpan/Test-Harness/t/taint.t @@ -1,7 +1,13 @@ #!/usr/bin/perl -w BEGIN { - unshift @INC, 't/lib'; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', 'lib' ); + } + else { + unshift @INC, 't/lib'; + } } # Test that options in PERL5OPT are propogated to tainted tests @@ -37,7 +43,7 @@ sub run_test_file { } { - local $ENV{PERL5OPT} = $ENV{PERL_CORE} ? '-I../../lib -Mstrict' : '-Mstrict'; + local $ENV{PERL5OPT} = $ENV{PERL_CORE} ? '-I../lib -Mstrict' : '-Mstrict'; run_test_file(<<'END'); #!/usr/bin/perl -T diff --git a/cpan/Test-Harness/t/testargs.t b/cpan/Test-Harness/t/testargs.t index aa3aa7337c..8ac9035bf9 100644 --- a/cpan/Test-Harness/t/testargs.t +++ b/cpan/Test-Harness/t/testargs.t @@ -1,15 +1,23 @@ #!/usr/bin/perl -w +BEGIN { + chdir 't' and @INC = '../lib' if $ENV{PERL_CORE}; +} + use strict; use lib 't/lib'; -use Test::More tests => 19; +use Test::More tests => 21; use File::Spec; use TAP::Parser; use TAP::Harness; use App::Prove; my $test = File::Spec->catfile( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test-Harness' ) + : () + ), 't', 'sample-tests', 'echo' @@ -39,12 +47,18 @@ for my $args ( [qw( yes no maybe )], [qw( 1 2 3 )] ) { } { - my $harness = TAP::Harness->new( - { verbosity => -9, test_args => [qw( magic hat brigade )] } ); - my $aggregate = $harness->runtests($test); - - is $aggregate->total, 3, "ran the right number of tests"; - is $aggregate->passed, 3, "and they passed"; + for my $test_arg_type ( + [qw( magic hat brigade )], + { $test => [qw( magic hat brigade )] }, + ) + { + my $harness = TAP::Harness->new( + { verbosity => -9, test_args => $test_arg_type } ); + my $aggregate = $harness->runtests($test); + + is $aggregate->total, 3, "ran the right number of tests"; + is $aggregate->passed, 3, "and they passed"; + } } package Test::Prove; diff --git a/cpan/Test-Harness/t/utils.t b/cpan/Test-Harness/t/utils.t index 4851ac1f1c..d60c8a2939 100644 --- a/cpan/Test-Harness/t/utils.t +++ b/cpan/Test-Harness/t/utils.t @@ -1,5 +1,9 @@ #!/usr/bin/perl -w +BEGIN { + chdir 't' and @INC = '../lib' if $ENV{PERL_CORE}; +} + use strict; use lib 't/lib'; |